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) ...@@ -30,7 +30,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument)
    import Gargantext.Database.Schema.User (insertUsersDemo) import Gargantext.Database.Schema.User (insertUsersDemo)
    import Gargantext.Text.Terms (TermType(..)) import Gargantext.Text.Terms (TermType(..))
    import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
    import Gargantext.API -- (GargError) import Gargantext.API.Types (GargError)
    import Gargantext.API.Node () -- instances import Gargantext.API.Node () -- instances
    import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv) import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
    import System.Environment (getArgs) import System.Environment (getArgs)
    ......
    bin/gargantext-init/Main.hs
    View file @ 76e11752
    ...@@ -28,7 +28,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument, RootId) ...@@ -28,7 +28,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument, RootId)
    import Gargantext.Database.Schema.User (insertUsersDemo, UserId) import Gargantext.Database.Schema.User (insertUsersDemo, UserId)
    import Gargantext.Text.Terms (TermType(..)) import Gargantext.Text.Terms (TermType(..))
    import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
    import Gargantext.API -- (GargError) import Gargantext.API.Types (GargError)
    import Gargantext.API.Node () -- instances import Gargantext.API.Node () -- instances
    import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv) import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
    --import Gargantext.Text.Corpus.Parsers.GrandDebat (readFile, GrandDebatReference(..)) --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 && \ RUN apt-get update && \
    apt-get install -y git libigraph0-dev && \ apt-get install -y git libigraph0-dev && \
    ......
    devops/docker/docker-postgres
    View file @ 76e11752
    ...@@ -4,6 +4,6 @@ docker rm --volumes dbgarg || : ...@@ -4,6 +4,6 @@ docker rm --volumes dbgarg || :
    export PGPASSWORD="$(grep DB_PASS gargantext.ini | \awk '{print $3}')" 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 docker run --name dbgarg -e POSTGRES_USER=gargantua -e POSTGRES_DB=gargandbV5 -e POSTGRES_PASSWORD=${PGPASSWORD} -d postgres
    sleep 3 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 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 #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: ...@@ -33,6 +33,7 @@ library:
    # - Gargantext.API.Orchestrator # - Gargantext.API.Orchestrator
    - Gargantext.API.Search - Gargantext.API.Search
    - Gargantext.API.Settings - Gargantext.API.Settings
    - Gargantext.API.Types
    - Gargantext.Core - Gargantext.Core
    - Gargantext.Core.Types - Gargantext.Core.Types
    - Gargantext.Core.Types.Main - Gargantext.Core.Types.Main
    ...@@ -130,7 +131,7 @@ library: ...@@ -130,7 +131,7 @@ library:
    - hlcm - hlcm
    - ini - ini
    - insert-ordered-containers - insert-ordered-containers
    - jose-jwt - jose
    # - kmeans-vector # - kmeans-vector
    - json-stream - json-stream
    - KMP - KMP
    ...@@ -160,6 +161,7 @@ library: ...@@ -160,6 +161,7 @@ library:
    - simple-reflect - simple-reflect
    - cereal # (IGraph) - cereal # (IGraph)
    - singletons # (IGraph) - singletons # (IGraph)
    - quickcheck-instances
    - random - random
    - rake - rake
    - regex-compat - regex-compat
    ...@@ -169,6 +171,8 @@ library: ...@@ -169,6 +171,8 @@ library:
    - semigroups - semigroups
    - servant - servant
    - servant-auth - servant-auth
    - servant-auth-server >= 0.4.4.0
    - servant-auth-swagger
    - servant-blaze - servant-blaze
    - servant-client - servant-client
    # - servant-job # - servant-job
    ......
    src/Gargantext/API.hs
    View file @ 76e11752
    ...@@ -55,6 +55,9 @@ import Network.Wai ...@@ -55,6 +55,9 @@ import Network.Wai
    import Network.Wai.Handler.Warp hiding (defaultSettings) import Network.Wai.Handler.Warp hiding (defaultSettings)
    import Servant import Servant
    import Servant.Auth as SA
    import Servant.Auth.Server (AuthResult(..))
    import Servant.Auth.Swagger ()
    import Servant.HTML.Blaze (HTML) import Servant.HTML.Blaze (HTML)
    --import Servant.Mock (mock) --import Servant.Mock (mock)
    --import Servant.Job.Server (WithCallbacks) --import Servant.Job.Server (WithCallbacks)
    ...@@ -68,7 +71,7 @@ import Text.Blaze.Html (Html) ...@@ -68,7 +71,7 @@ import Text.Blaze.Html (Html)
    --import Gargantext.API.Swagger --import Gargantext.API.Swagger
    --import Gargantext.Database.Node.Contact (HyperdataContact) --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.Count ( CountAPI, count, Query)
    import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer) import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
    import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, TableNgramsApi, apiNgramsTableDoc) import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, TableNgramsApi, apiNgramsTableDoc)
    ...@@ -76,9 +79,6 @@ import Gargantext.API.Node ...@@ -76,9 +79,6 @@ import Gargantext.API.Node
    import Gargantext.API.Search (SearchPairsAPI, searchPairs) import Gargantext.API.Search (SearchPairsAPI, searchPairs)
    import Gargantext.API.Types import Gargantext.API.Types
    import qualified Gargantext.API.Corpus.New as New 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
    import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId) import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
    import Gargantext.Database.Utils (HasConnection) import Gargantext.Database.Utils (HasConnection)
    ...@@ -109,24 +109,8 @@ import Network.HTTP.Types hiding (Query) ...@@ -109,24 +109,8 @@ import Network.HTTP.Types hiding (Query)
    import Gargantext.API.Settings import Gargantext.API.Settings
    data GargError showAsServantErr :: GargError -> ServerError
    = GargNodeError NodeError showAsServantErr (GargServerError err) = err
    | 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 a = err500 { errBody = BL8.pack $ show a } showAsServantErr a = err500 { errBody = BL8.pack $ show a }
    fireWall :: Applicative f => Request -> FireWall -> f Bool fireWall :: Applicative f => Request -> FireWall -> f Bool
    ...@@ -231,15 +215,26 @@ type GargAPI' = ...@@ -231,15 +215,26 @@ type GargAPI' =
    "auth" :> Summary "AUTH API" "auth" :> Summary "AUTH API"
    :> ReqBody '[JSON] AuthRequest :> ReqBody '[JSON] AuthRequest
    :> Post '[JSON] AuthResponse :> Post '[JSON] AuthResponse
    -- TODO-ACCESS here we want to request a particular header for
    -- Roots endpoint -- auth and capabilities.
    :<|> "user" :> Summary "First user endpoint" :<|> GargPrivateAPI
    type GargPrivateAPI = SA.Auth '[SA.JWT] AuthenticatedUser :> GargPrivateAPI'
    type GargAdminAPI
    -- Roots endpoint
    = "user" :> Summary "First user endpoint"
    :> Roots :> Roots
    :<|> "nodes" :> Summary "Nodes endpoint"
    :> ReqBody '[JSON] [NodeId] :> NodesAPI
    type GargPrivateAPI' =
    GargAdminAPI
    -- Node endpoint -- Node endpoint
    :<|> "node" :> Summary "Node endpoint" :<|> "node" :> Summary "Node endpoint"
    :> Capture "id" NodeId :> NodeAPI HyperdataAny :> Capture "id" NodeId :> NodeAPI HyperdataAny
    -- Corpus endpoint -- Corpus endpoint
    :<|> "corpus":> Summary "Corpus endpoint" :<|> "corpus":> Summary "Corpus endpoint"
    :> Capture "id" CorpusId :> NodeAPI HyperdataCorpus :> Capture "id" CorpusId :> NodeAPI HyperdataCorpus
    ...@@ -251,16 +246,12 @@ type GargAPI' = ...@@ -251,16 +246,12 @@ type GargAPI' =
    -- Document endpoint -- Document endpoint
    :<|> "document":> Summary "Document endpoint" :<|> "document":> Summary "Document endpoint"
    :> Capture "id" DocId :> "ngrams" :> TableNgramsApi :> Capture "id" DocId :> "ngrams" :> TableNgramsApi
    -- Corpus endpoint
    :<|> "nodes" :> Summary "Nodes endpoint"
    :> ReqBody '[JSON] [NodeId] :> NodesAPI
    -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
    -- Corpus endpoint -- TODO-SECURITY
    :<|> "count" :> Summary "Count endpoint" :<|> "count" :> Summary "Count endpoint"
    :> ReqBody '[JSON] Query :> CountAPI :> ReqBody '[JSON] Query :> CountAPI
    -- Corpus endpoint --> TODO rename s/search/filter/g -- Corpus endpoint --> TODO rename s/search/filter/g
    :<|> "search":> Capture "corpus" NodeId :> SearchPairsAPI :<|> "search":> Capture "corpus" NodeId :> SearchPairsAPI
    ...@@ -290,6 +281,10 @@ type SwaggerFrontAPI = SwaggerAPI :<|> FrontEndAPI ...@@ -290,6 +281,10 @@ type SwaggerFrontAPI = SwaggerAPI :<|> FrontEndAPI
    type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html 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 -- | Server declarations
    ...@@ -298,30 +293,42 @@ server :: forall env. (HasConnection env, HasRepo env, HasSettings env) ...@@ -298,30 +293,42 @@ server :: forall env. (HasConnection env, HasRepo env, HasSettings env)
    server env = do server env = do
    -- orchestrator <- scrapyOrchestrator env -- orchestrator <- scrapyOrchestrator env
    pure $ swaggerFront pure $ swaggerFront
    :<|> hoistServer (Proxy :: Proxy GargAPI) transform serverGargAPI :<|> hoistServerWithContext (Proxy :: Proxy GargAPI) (Proxy :: Proxy AuthContext) transform serverGargAPI
    :<|> serverStatic :<|> serverStatic
    where 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) transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
    serverGargAPI :: GargServer GargAPI serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
    serverGargAPI -- orchestrator serverGargAPI -- orchestrator
    = auth = auth :<|> serverPrivateGargAPI
    :<|> 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
    -- :<|> orchestrator -- :<|> 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 :: Server (Get '[HTML] Html)
    serverStatic = $(do serverStatic = $(do
    ...@@ -341,7 +348,13 @@ swaggerFront = schemaUiServer swaggerDoc ...@@ -341,7 +348,13 @@ swaggerFront = schemaUiServer swaggerDoc
    --------------------------------------------------------------------- ---------------------------------------------------------------------
    makeApp :: (HasConnection env, HasRepo env, HasSettings env) makeApp :: (HasConnection env, HasRepo env, HasSettings env)
    => env -> IO Application => 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 :: Application
    --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic) --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 ...@@ -16,27 +16,40 @@ Main authorisation of Gargantext are managed in this module
    -- 2: Implement the Auth API backend -- 2: Implement the Auth API backend
    https://github.com/haskell-servant/servant-auth https://github.com/haskell-servant/servant-auth
    TODO-ACCESS Critical
    -} -}
    {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TemplateHaskell #-}
    module Gargantext.API.Auth module Gargantext.API.Auth
    where where
    import Control.Lens (view)
    import Control.Monad.IO.Class (liftIO)
    import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
    import Data.List (elem) import Data.List (elem)
    import Data.Swagger import Data.Swagger
    import Data.Text (Text, reverse) import Data.Text (Text, reverse)
    import Data.Text.Lazy (toStrict)
    import Data.Text.Lazy.Encoding (decodeUtf8)
    import GHC.Generics (Generic) 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.Root (getRoot)
    import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId) import Gargantext.Database.Tree (isDescendantOf)
    import Gargantext.Database.Utils (Cmd) import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId(..), UserId)
    import Gargantext.Database.Utils (Cmd', CmdM, HasConnection)
    import Gargantext.Prelude hiding (reverse) import Gargantext.Prelude hiding (reverse)
    import Test.QuickCheck (elements, oneof) import Test.QuickCheck (elements, oneof)
    import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    ...@@ -74,15 +87,30 @@ type TreeId = NodeId ...@@ -74,15 +87,30 @@ type TreeId = NodeId
    data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
    deriving (Eq) 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 checkAuthRequest u p
    | not (u `elem` arbitraryUsername) = pure InvalidUser | not (u `elem` arbitraryUsername) = pure InvalidUser
    | u /= reverse p = pure InvalidPassword | u /= reverse p = pure InvalidPassword
    | otherwise = do | otherwise = do
    muId <- getRoot "user1" muId <- head <$> getRoot "user1" -- TODO user1 hard-coded
    pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId case _node_id <$> muId of
    Nothing -> pure InvalidUser
    auth :: AuthRequest -> Cmd err AuthResponse 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 auth (AuthRequest u p) = do
    checkAuthRequest' <- checkAuthRequest u p checkAuthRequest' <- checkAuthRequest u p
    case checkAuthRequest' of case checkAuthRequest' of
    ...@@ -90,9 +118,36 @@ auth (AuthRequest u p) = do ...@@ -90,9 +118,36 @@ auth (AuthRequest u p) = do
    InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password") InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
    Valid to trId -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing 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 -- | Instances
    $(deriveJSON (unPrefix "_authReq_") ''AuthRequest) $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
    instance ToSchema AuthRequest instance ToSchema AuthRequest where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
    instance Arbitrary AuthRequest where instance Arbitrary AuthRequest where
    arbitrary = elements [ AuthRequest u p arbitrary = elements [ AuthRequest u p
    ...@@ -101,23 +156,40 @@ instance Arbitrary AuthRequest where ...@@ -101,23 +156,40 @@ instance Arbitrary AuthRequest where
    ] ]
    $(deriveJSON (unPrefix "_authRes_") ''AuthResponse) $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
    instance ToSchema AuthResponse instance ToSchema AuthResponse where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
    instance Arbitrary AuthResponse where instance Arbitrary AuthResponse where
    arbitrary = oneof [ AuthResponse Nothing . Just <$> arbitrary arbitrary = oneof [ AuthResponse Nothing . Just <$> arbitrary
    , flip AuthResponse Nothing . Just <$> arbitrary ] , flip AuthResponse Nothing . Just <$> arbitrary ]
    $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid) $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
    instance ToSchema AuthInvalid instance ToSchema AuthInvalid where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
    instance Arbitrary AuthInvalid where instance Arbitrary AuthInvalid where
    arbitrary = elements [ AuthInvalid m arbitrary = elements [ AuthInvalid m
    | m <- [ "Invalid user", "Invalid password"] | m <- [ "Invalid user", "Invalid password"]
    ] ]
    $(deriveJSON (unPrefix "_authVal_") ''AuthValid) $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
    instance ToSchema AuthValid instance ToSchema AuthValid where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
    instance Arbitrary AuthValid where instance Arbitrary AuthValid where
    arbitrary = elements [ AuthValid to tr arbitrary = elements [ AuthValid to tr
    | to <- ["token0", "token1"] | to <- ["token0", "token1"]
    , tr <- [1..3] , 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) ...@@ -30,7 +30,7 @@ import Data.Aeson.TH (deriveJSON)
    import Data.Swagger import Data.Swagger
    import Data.Text (Text) import Data.Text (Text)
    import GHC.Generics (Generic) 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.Flow (flowCorpusSearchInDatabase)
    import Gargantext.Database.Types.Node (CorpusId) import Gargantext.Database.Types.Node (CorpusId)
    import Gargantext.Text.Terms (TermType(..)) import Gargantext.Text.Terms (TermType(..))
    ...@@ -60,9 +60,7 @@ instance Arbitrary Query where ...@@ -60,9 +60,7 @@ instance Arbitrary Query where
    ] ]
    instance ToSchema Query where instance ToSchema Query where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 6 fieldLabel}
    type Api = Summary "New Corpus endpoint" type Api = Summary "New Corpus endpoint"
    :> ReqBody '[JSON] Query :> ReqBody '[JSON] Query
    ...@@ -70,6 +68,8 @@ type Api = Summary "New Corpus endpoint" ...@@ -70,6 +68,8 @@ type Api = Summary "New Corpus endpoint"
    :<|> Get '[JSON] ApiInfo :<|> Get '[JSON] ApiInfo
    -- | TODO manage several apis -- | TODO manage several apis
    -- TODO-ACCESS
    -- TODO this is only the POST
    api :: (FlowCmdM env err m) => Query -> m CorpusId api :: (FlowCmdM env err m) => Query -> m CorpusId
    api (Query q _ as) = do api (Query q _ as) = do
    cId <- case head as of cId <- case head as of
    ......
    src/Gargantext/API/Count.hs
    View file @ 76e11752
    ...@@ -41,7 +41,7 @@ import Test.QuickCheck (elements) ...@@ -41,7 +41,7 @@ import Test.QuickCheck (elements)
    -- import Control.Applicative ((<*>)) -- import Control.Applicative ((<*>))
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    ----------------------------------------------------------------------- -----------------------------------------------------------------------
    -- TODO-ACCESS: CanCount -- TODO-ACCESS: CanCount
    ...@@ -93,7 +93,9 @@ instance Arbitrary Query where ...@@ -93,7 +93,9 @@ instance Arbitrary Query where
    , n <- take 10 $ permutations scrapers , n <- take 10 $ permutations scrapers
    ] ]
    instance ToSchema Query instance ToSchema Query where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
    ----------------------------------------------------------------------- -----------------------------------------------------------------------
    type Code = Integer type Code = Integer
    type Error = Text type Error = Text
    ...@@ -144,7 +146,8 @@ data Count = Count { count_name :: Scraper ...@@ -144,7 +146,8 @@ data Count = Count { count_name :: Scraper
    $(deriveJSON (unPrefix "count_") ''Count) $(deriveJSON (unPrefix "count_") ''Count)
    instance ToSchema Count instance ToSchema Count where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "count_")
    --instance Arbitrary Count where --instance Arbitrary Count where
    -- arbitrary = Count <$> arbitrary <*> arbitrary <*> arbitrary -- arbitrary = Count <$> arbitrary <*> arbitrary <*> arbitrary
    ......
    src/Gargantext/API/Metrics.hs
    View file @ 76e11752
    ...@@ -31,7 +31,7 @@ import Data.Time (UTCTime) ...@@ -31,7 +31,7 @@ import Data.Time (UTCTime)
    import Data.Text (Text) import Data.Text (Text)
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import Gargantext.Core.Types (ListType(..)) import Gargantext.Core.Types (ListType(..))
    import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Utils import Gargantext.Database.Utils
    import Gargantext.Core.Types (CorpusId, ListId, Limit) import Gargantext.Core.Types (CorpusId, ListId, Limit)
    import Gargantext.Prelude import Gargantext.Prelude
    ...@@ -50,7 +50,8 @@ data Metrics = Metrics ...@@ -50,7 +50,8 @@ data Metrics = Metrics
    { metrics_data :: [Metric]} { metrics_data :: [Metric]}
    deriving (Generic, Show) deriving (Generic, Show)
    instance ToSchema Metrics instance ToSchema Metrics where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "metrics_")
    instance Arbitrary Metrics instance Arbitrary Metrics
    where where
    arbitrary = Metrics <$> arbitrary arbitrary = Metrics <$> arbitrary
    ...@@ -62,7 +63,8 @@ data Metric = Metric ...@@ -62,7 +63,8 @@ data Metric = Metric
    , m_cat :: !ListType , m_cat :: !ListType
    } deriving (Generic, Show) } deriving (Generic, Show)
    instance ToSchema Metric instance ToSchema Metric where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "m_")
    instance Arbitrary Metric instance Arbitrary Metric
    where where
    arbitrary = Metric <$> arbitrary arbitrary = Metric <$> arbitrary
    ...@@ -78,7 +80,8 @@ deriveJSON (unPrefix "m_") ''Metric ...@@ -78,7 +80,8 @@ deriveJSON (unPrefix "m_") ''Metric
    data ChartMetrics a = ChartMetrics { chartMetrics_data :: a } data ChartMetrics a = ChartMetrics { chartMetrics_data :: a }
    deriving (Generic, Show) 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) instance (Arbitrary a) => Arbitrary (ChartMetrics a)
    where where
    arbitrary = ChartMetrics <$> arbitrary arbitrary = ChartMetrics <$> arbitrary
    ...@@ -86,7 +89,8 @@ instance (Arbitrary a) => Arbitrary (ChartMetrics a) ...@@ -86,7 +89,8 @@ instance (Arbitrary a) => Arbitrary (ChartMetrics a)
    deriveJSON (unPrefix "chartMetrics_") ''ChartMetrics deriveJSON (unPrefix "chartMetrics_") ''ChartMetrics
    ------------------------------------------------------------- -------------------------------------------------------------
    instance ToSchema Histo instance ToSchema Histo where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "histo_")
    instance Arbitrary Histo instance Arbitrary Histo
    where where
    arbitrary = elements [ Histo ["2012"] [1] arbitrary = elements [ Histo ["2012"] [1]
    ...@@ -95,11 +99,6 @@ instance Arbitrary Histo ...@@ -95,11 +99,6 @@ instance Arbitrary Histo
    deriveJSON (unPrefix "histo_") ''Histo deriveJSON (unPrefix "histo_") ''Histo
    instance ToSchema MyTree
    instance Arbitrary MyTree
    where
    arbitrary = MyTree <$> arbitrary <*> arbitrary <*> arbitrary
    ------------------------------------------------------------- -------------------------------------------------------------
    -- | Scatter metrics API -- | Scatter metrics API
    ......
    src/Gargantext/API/Ngrams.hs
    View file @ 76e11752
    {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
    {-| {-|
    Module : Gargantext.API.Ngrams Module : Gargantext.API.Ngrams
    Description : Server API Description : Server API
    ...@@ -32,6 +33,52 @@ add get ...@@ -32,6 +33,52 @@ add get
    {-# OPTIONS -fno-warn-orphans #-} {-# OPTIONS -fno-warn-orphans #-}
    module Gargantext.API.Ngrams 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 where
    -- import Debug.Trace (trace) -- import Debug.Trace (trace)
    ...@@ -69,7 +116,7 @@ import Data.Swagger hiding (version, patch) ...@@ -69,7 +116,7 @@ import Data.Swagger hiding (version, patch)
    import Data.Text (Text, isInfixOf, count) import Data.Text (Text, isInfixOf, count)
    import Data.Validity import Data.Validity
    import GHC.Generics (Generic) 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.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
    import Gargantext.Database.Config (userMaster) import Gargantext.Database.Config (userMaster)
    import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast) import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast)
    ...@@ -208,7 +255,8 @@ mkNgramsElement ngrams list rp children = ...@@ -208,7 +255,8 @@ mkNgramsElement ngrams list rp children =
    newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
    newNgramsElement mayList ngrams = mkNgramsElement ngrams (fromMaybe GraphTerm mayList) Nothing mempty 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 instance Arbitrary NgramsElement where
    arbitrary = elements [newNgramsElement Nothing "sport"] arbitrary = elements [newNgramsElement Nothing "sport"]
    ...@@ -462,7 +510,8 @@ data NgramsPatch = ...@@ -462,7 +510,8 @@ data NgramsPatch =
    deriveJSON (unPrefix "_") ''NgramsPatch deriveJSON (unPrefix "_") ''NgramsPatch
    makeLenses ''NgramsPatch makeLenses ''NgramsPatch
    instance ToSchema NgramsPatch instance ToSchema NgramsPatch where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
    instance Arbitrary NgramsPatch where instance Arbitrary NgramsPatch where
    arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary) arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
    ...@@ -597,7 +646,8 @@ data Versioned a = Versioned ...@@ -597,7 +646,8 @@ data Versioned a = Versioned
    deriving (Generic, Show) deriving (Generic, Show)
    deriveJSON (unPrefix "_v_") ''Versioned deriveJSON (unPrefix "_v_") ''Versioned
    makeLenses ''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 instance Arbitrary a => Arbitrary (Versioned a) where
    arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
    ...@@ -798,12 +848,14 @@ putListNgrams listId ngramsType nes = do ...@@ -798,12 +848,14 @@ putListNgrams listId ngramsType nes = do
    where where
    m = Map.fromList $ (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) <$> nes 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 :: RepoCmdM env err m => TabType -> NodeId -> Maybe ListType -> [NgramsTerm] -> m ()
    tableNgramsPost tabType listId mayList = tableNgramsPost tabType listId mayList =
    putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList) putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
    -- Apply the given patch to the DB and returns the patch to be applied on the -- Apply the given patch to the DB and returns the patch to be applied on the
    -- client. -- client.
    -- TODO-ACCESS check
    tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m) tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
    => TabType -> ListId => TabType -> ListId
    -> Versioned NgramsTablePatch -> Versioned NgramsTablePatch
    ......
    src/Gargantext/API/Ngrams/NTree.hs
    View file @ 76e11752
    ...@@ -23,16 +23,18 @@ import Data.Text (Text) ...@@ -23,16 +23,18 @@ import Data.Text (Text)
    import Gargantext.Prelude import Gargantext.Prelude
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import Data.Aeson.TH (deriveJSON) 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.Core.Types (ListType(..), NodeId)
    import Gargantext.API.Ngrams import Gargantext.API.Ngrams
    import Data.Tree import Data.Tree
    import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
    import Data.Map (Map) import Data.Map (Map)
    import Data.Set (Set) import Data.Set (Set)
    import Data.Swagger
    import qualified Data.Set as Set import qualified Data.Set as Set
    import qualified Data.Map as Map import qualified Data.Map as Map
    import qualified Data.List as List import qualified Data.List as List
    import Test.QuickCheck
    type Children = Text type Children = Text
    type Root = Text type Root = Text
    ...@@ -47,12 +49,17 @@ toMyTree (Node (l,v) xs) = MyTree l v (map toMyTree xs) ...@@ -47,12 +49,17 @@ toMyTree (Node (l,v) xs) = MyTree l v (map toMyTree xs)
    deriveJSON (unPrefix "mt_") ''MyTree 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 :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [MyTree]
    toTree lt vs m = map toMyTree $ unfoldForest buildNode roots toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
    where where
    buildNode r = maybe ((r, value r),[]) (\x -> ((r, value r), mSetToList $ _nre_children x)) (Map.lookup r m) 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 value l = maybe 0 (fromIntegral . Set.size) $ Map.lookup l vs
    rootsCandidates = catMaybes rootsCandidates = catMaybes
    ...@@ -60,7 +67,7 @@ toTree lt vs m = map toMyTree $ unfoldForest buildNode roots ...@@ -60,7 +67,7 @@ toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
    $ map (\(c,c') -> case _nre_root c' of $ map (\(c,c') -> case _nre_root c' of
    Nothing -> Just c Nothing -> Just c
    _ -> _nre_root c' ) (Map.toList m) _ -> _nre_root c' ) (Map.toList m)
    roots = map fst roots = map fst
    $ filter (\(_,l) -> l == lt) $ filter (\(_,l) -> l == lt)
    $ catMaybes $ catMaybes
    ......
    src/Gargantext/API/Ngrams/Tools.hs
    View file @ 76e11752
    ...@@ -33,6 +33,10 @@ import qualified Data.Set as Set ...@@ -33,6 +33,10 @@ import qualified Data.Set as Set
    type RootTerm = Text 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 getListNgrams :: RepoCmdM env err m
    => [ListId] -> NgramsType => [ListId] -> NgramsType
    -> m (Map Text NgramsRepoElement) -> m (Map Text NgramsRepoElement)
    ......
    src/Gargantext/API/Node.hs
    View file @ 76e11752
    ...@@ -7,6 +7,8 @@ Maintainer : team@gargantext.org ...@@ -7,6 +7,8 @@ Maintainer : team@gargantext.org
    Stability : experimental Stability : experimental
    Portability : POSIX Portability : POSIX
    -- TODO-SECURITY: Critical
    -- TODO-ACCESS: CanGetNode -- TODO-ACCESS: CanGetNode
    -- TODO-EVENTS: No events as this is a read only query. -- TODO-EVENTS: No events as this is a read only query.
    Node API Node API
    ...@@ -46,6 +48,7 @@ import Data.Swagger ...@@ -46,6 +48,7 @@ import Data.Swagger
    import Data.Text (Text()) import Data.Text (Text())
    import Data.Time (UTCTime) import Data.Time (UTCTime)
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import Gargantext.API.Auth (withAccess)
    import Gargantext.API.Metrics import Gargantext.API.Metrics
    import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO) import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
    import Gargantext.API.Ngrams.NTree (MyTree) import Gargantext.API.Ngrams.NTree (MyTree)
    ...@@ -156,11 +159,14 @@ type ChildrenApi a = Summary " Summary children" ...@@ -156,11 +159,14 @@ type ChildrenApi a = Summary " Summary children"
    :> QueryParam "offset" Int :> QueryParam "offset" Int
    :> QueryParam "limit" Int :> QueryParam "limit" Int
    :> Get '[JSON] [Node a] :> Get '[JSON] [Node a]
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy. -- 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 :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
    nodeAPI p uId id nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId id nodeAPI'
    = getNode id p where
    nodeAPI' :: GargServer (NodeAPI a)
    nodeAPI' = getNode id p
    :<|> rename id :<|> rename id
    :<|> postNode uId id :<|> postNode uId id
    :<|> putNode id :<|> putNode id
    ...@@ -172,18 +178,18 @@ nodeAPI p uId id ...@@ -172,18 +178,18 @@ nodeAPI p uId id
    :<|> apiNgramsTableCorpus id :<|> apiNgramsTableCorpus id
    :<|> getPairing id :<|> getPairing id
    -- :<|> getTableNgramsDoc id -- :<|> getTableNgramsDoc id
    :<|> catApi id :<|> catApi id
    :<|> searchDocs id :<|> searchDocs id
    :<|> getScatter id :<|> getScatter id
    :<|> getChart id :<|> getChart id
    :<|> getPie id :<|> getPie id
    :<|> getTree id :<|> getTree id
    :<|> phyloAPI id uId :<|> phyloAPI id uId
    :<|> postUpload id :<|> postUpload id
    where
    deleteNodeApi id' = do deleteNodeApi id' = do
    node <- getNode' id' node <- getNode' id'
    if _node_typename node == nodeTypeId NodeUser if _node_typename node == nodeTypeId NodeUser
    ...@@ -196,6 +202,7 @@ nodeAPI p uId id ...@@ -196,6 +202,7 @@ nodeAPI p uId id
    data RenameNode = RenameNode { r_name :: Text } data RenameNode = RenameNode { r_name :: Text }
    deriving (Generic) deriving (Generic)
    -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
    instance FromJSON RenameNode instance FromJSON RenameNode
    instance ToJSON RenameNode instance ToJSON RenameNode
    instance ToSchema RenameNode instance ToSchema RenameNode
    ...@@ -206,6 +213,7 @@ data PostNode = PostNode { pn_name :: Text ...@@ -206,6 +213,7 @@ data PostNode = PostNode { pn_name :: Text
    , pn_typename :: NodeType} , pn_typename :: NodeType}
    deriving (Generic) deriving (Generic)
    -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
    instance FromJSON PostNode instance FromJSON PostNode
    instance ToJSON PostNode instance ToJSON PostNode
    instance ToSchema PostNode instance ToSchema PostNode
    ...@@ -222,6 +230,7 @@ data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId] ...@@ -222,6 +230,7 @@ data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
    } }
    deriving (Generic) deriving (Generic)
    -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
    instance FromJSON NodesToCategory instance FromJSON NodesToCategory
    instance ToJSON NodesToCategory instance ToJSON NodesToCategory
    instance ToSchema NodesToCategory instance ToSchema NodesToCategory
    ...@@ -301,8 +310,7 @@ instance HasTreeError ServantErr where ...@@ -301,8 +310,7 @@ instance HasTreeError ServantErr where
    -} -}
    type TreeAPI = Get '[JSON] (Tree NodeTree) 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 :: NodeId -> GargServer TreeAPI
    treeAPI = treeDB treeAPI = treeDB
    ......
    src/Gargantext/API/Search.hs
    View file @ 76e11752
    ...@@ -35,7 +35,7 @@ import Test.QuickCheck (elements) ...@@ -35,7 +35,7 @@ import Test.QuickCheck (elements)
    -- import Control.Applicative ((<*>)) -- import Control.Applicative ((<*>))
    import Gargantext.API.Types (GargServer) import Gargantext.API.Types (GargServer)
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Database.Types.Node import Gargantext.Database.Types.Node
    import Gargantext.Database.TextSearch import Gargantext.Database.TextSearch
    import Gargantext.Database.Facet import Gargantext.Database.Facet
    ...@@ -48,9 +48,7 @@ data SearchQuery = SearchQuery ...@@ -48,9 +48,7 @@ data SearchQuery = SearchQuery
    $(deriveJSON (unPrefix "sq_") ''SearchQuery) $(deriveJSON (unPrefix "sq_") ''SearchQuery)
    instance ToSchema SearchQuery where instance ToSchema SearchQuery where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sq_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = drop 3}
    instance Arbitrary SearchQuery where instance Arbitrary SearchQuery where
    arbitrary = elements [SearchQuery ["electrodes"]] arbitrary = elements [SearchQuery ["electrodes"]]
    ...@@ -64,9 +62,7 @@ instance Arbitrary SearchDocResults where ...@@ -64,9 +62,7 @@ instance Arbitrary SearchDocResults where
    arbitrary = SearchDocResults <$> arbitrary arbitrary = SearchDocResults <$> arbitrary
    instance ToSchema SearchDocResults where instance ToSchema SearchDocResults where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sdr_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = drop 4}
    data SearchPairedResults = SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] } data SearchPairedResults = SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] }
    deriving (Generic) deriving (Generic)
    ...@@ -76,9 +72,7 @@ instance Arbitrary SearchPairedResults where ...@@ -76,9 +72,7 @@ instance Arbitrary SearchPairedResults where
    arbitrary = SearchPairedResults <$> arbitrary arbitrary = SearchPairedResults <$> arbitrary
    instance ToSchema SearchPairedResults where instance ToSchema SearchPairedResults where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "spr_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    ----------------------------------------------------------------------- -----------------------------------------------------------------------
    -- TODO-ACCESS: CanSearch? or is it part of CanGetNode -- 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 ...@@ -6,6 +6,8 @@ License : AGPL + CECILL v3
    Maintainer : team@gargantext.org Maintainer : team@gargantext.org
    Stability : experimental Stability : experimental
    Portability : POSIX Portability : POSIX
    TODO-SECURITY: Critical
    -} -}
    {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
    ...@@ -40,16 +42,15 @@ import Data.Aeson ...@@ -40,16 +42,15 @@ import Data.Aeson
    import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
    import Data.Either (either) import Data.Either (either)
    import Data.Text import Data.Text
    import Data.Text.Encoding (encodeUtf8) --import Data.Text.Encoding (encodeUtf8)
    import Data.ByteString (ByteString) import Data.ByteString (ByteString)
    import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
    import Servant import Servant
    import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings, defaultCookieSettings, readKey, writeKey)
    import Servant.Client (BaseUrl, parseBaseUrl) import Servant.Client (BaseUrl, parseBaseUrl)
    --import Servant.Job.Async (newJobEnv, defaultSettings) --import Servant.Job.Async (newJobEnv, defaultSettings)
    import Web.HttpApiData (parseUrlPiece) import Web.HttpApiData (parseUrlPiece)
    import qualified Jose.Jwk as Jose
    import qualified Jose.Jwa as Jose
    import Control.Concurrent import Control.Concurrent
    import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction) import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
    ...@@ -77,7 +78,8 @@ data Settings = Settings ...@@ -77,7 +78,8 @@ data Settings = Settings
    , _logLevelLimit :: LogLevel -- log level from the monad-logger package , _logLevelLimit :: LogLevel -- log level from the monad-logger package
    -- , _dbServer :: Text -- , _dbServer :: Text
    -- ^ this is not used yet -- ^ this is not used yet
    , _jwtSecret :: Jose.Jwk -- key from the jose-jwt package , _jwtSettings :: JWTSettings
    , _cookieSettings :: CookieSettings
    , _sendLoginEmails :: SendEmailType , _sendLoginEmails :: SendEmailType
    , _scrapydUrl :: BaseUrl , _scrapydUrl :: BaseUrl
    , _fileFolder :: FilePath , _fileFolder :: FilePath
    ...@@ -89,29 +91,22 @@ class HasSettings env where ...@@ -89,29 +91,22 @@ class HasSettings env where
    settings :: Getter env Settings settings :: Getter env Settings
    parseJwk :: Text -> Jose.Jwk devSettings :: FilePath -> IO Settings
    parseJwk secretStr = jwk devSettings jwkFile = do
    where jwkExists <- doesFileExist jwkFile
    secretBs = encodeUtf8 secretStr when (not jwkExists) $ writeKey jwkFile
    jwk = Jose.SymmetricJwk secretBs jwk <- readKey jwkFile
    Nothing pure $ Settings
    Nothing
    (Just $ Jose.Signed Jose.HS256)
    devSettings :: Settings
    devSettings = Settings
    { _allowedOrigin = "http://localhost:8008" { _allowedOrigin = "http://localhost:8008"
    , _allowedHost = "localhost:3000" , _allowedHost = "localhost:3000"
    , _appPort = 3000 , _appPort = 3000
    , _logLevelLimit = LevelDebug , _logLevelLimit = LevelDebug
    -- , _dbServer = "localhost" -- , _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 , _sendLoginEmails = LogEmailToConsole
    , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800" , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
    , _fileFolder = "data" , _fileFolder = "data"
    , _cookieSettings = defaultCookieSettings -- TODO-SECURITY tune
    , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
    } }
    ...@@ -232,10 +227,13 @@ readRepoEnv = do ...@@ -232,10 +227,13 @@ readRepoEnv = do
    saver <- mkRepoSaver mvar saver <- mkRepoSaver mvar
    pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock } pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
    devJwkFile :: FilePath
    devJwkFile = "dev.jwk"
    newEnv :: PortNumber -> FilePath -> IO Env newEnv :: PortNumber -> FilePath -> IO Env
    newEnv port file = do newEnv port file = do
    manager <- newTlsManager manager <- newTlsManager
    settings <- pure (devSettings & appPort .~ port) -- TODO read from 'file' settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
    when (port /= settings ^. appPort) $ when (port /= settings ^. appPort) $
    panic "TODO: conflicting settings of port" panic "TODO: conflicting settings of port"
    ...@@ -295,10 +293,11 @@ withDevEnv iniPath k = do ...@@ -295,10 +293,11 @@ withDevEnv iniPath k = do
    param <- databaseParameters iniPath param <- databaseParameters iniPath
    conn <- connect param conn <- connect param
    repo <- readRepoEnv repo <- readRepoEnv
    setts <- devSettings devJwkFile
    pure $ DevEnv pure $ DevEnv
    { _dev_env_conn = conn { _dev_env_conn = conn
    , _dev_env_repo = repo , _dev_env_repo = repo
    , _dev_env_settings = devSettings , _dev_env_settings = setts
    } }
    -- | Run Cmd Sugar for the Repl (GHCI) -- | Run Cmd Sugar for the Repl (GHCI)
    ......
    src/Gargantext/API/Table.hs
    View file @ 76e11752
    ...@@ -45,7 +45,7 @@ import Data.Text (Text()) ...@@ -45,7 +45,7 @@ import Data.Text (Text())
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import Gargantext.API.Ngrams (TabType(..)) import Gargantext.API.Ngrams (TabType(..))
    import Gargantext.Core.Types (Offset, Limit) 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.Facet (FacetDoc , runViewDocuments, OrderBy(..),runViewAuthorsDoc)
    import Gargantext.Database.Learn (FavOrTrash(..), moreLike) import Gargantext.Database.Learn (FavOrTrash(..), moreLike)
    import Gargantext.Database.TextSearch import Gargantext.Database.TextSearch
    ...@@ -73,9 +73,7 @@ data TableQuery = TableQuery ...@@ -73,9 +73,7 @@ data TableQuery = TableQuery
    $(deriveJSON (unPrefix "tq_") ''TableQuery) $(deriveJSON (unPrefix "tq_") ''TableQuery)
    instance ToSchema TableQuery where instance ToSchema TableQuery where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "tq_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = drop 3}
    instance Arbitrary TableQuery where instance Arbitrary TableQuery where
    arbitrary = elements [TableQuery 0 10 DateAsc Docs "electrodes"] arbitrary = elements [TableQuery 0 10 DateAsc Docs "electrodes"]
    ......
    src/Gargantext/API/Types.hs
    View file @ 76e11752
    ...@@ -10,13 +10,26 @@ Portability : POSIX ...@@ -10,13 +10,26 @@ Portability : POSIX
    -} -}
    {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-}
    {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE FunctionalDependencies #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeOperators #-}
    {-# LANGUAGE UndecidableInstances #-}
    module Gargantext.API.Types module Gargantext.API.Types
    where 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 Servant
    import Gargantext.Prelude
    import Gargantext.API.Settings import Gargantext.API.Settings
    import Gargantext.API.Ngrams import Gargantext.API.Ngrams
    import Gargantext.Database.Tree import Gargantext.Database.Tree
    ...@@ -24,18 +37,75 @@ import Gargantext.Core.Types ...@@ -24,18 +37,75 @@ import Gargantext.Core.Types
    import Gargantext.Database.Utils import Gargantext.Database.Utils
    import Gargantext.Database.Schema.Node import Gargantext.Database.Schema.Node
    class HasServerError e where
    _ServerError :: Prism' e ServerError
    type GargServer api = serverError :: (MonadError e m, HasServerError e) => ServerError -> m a
    forall env err m. 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 ( CmdM env err m
    , HasNodeError err , HasNodeError err
    , HasInvalidError err , HasInvalidError err
    , HasTreeError err , HasTreeError err
    , HasServerError err
    , HasJoseError err
    , HasRepo env , HasRepo env
    , HasSettings 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 ...@@ -21,22 +21,6 @@ import Gargantext.Prelude
    import Data.Maybe (Maybe, fromMaybe) import Data.Maybe (Maybe, fromMaybe)
    import Prelude (String) import Prelude (String)
    import qualified Data.Text as T 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 ?| infixr 4 ?|
    ......
    src/Gargantext/Core/Types/Main.hs
    View file @ 76e11752
    ...@@ -22,8 +22,7 @@ module Gargantext.Core.Types.Main where ...@@ -22,8 +22,7 @@ module Gargantext.Core.Types.Main where
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    import Prelude (Enum, Bounded, minBound, maxBound) import Prelude (Enum, Bounded, minBound, maxBound)
    import Data.Aeson (FromJSON, ToJSON, toJSON) import Data.Aeson (FromJSON, ToJSON)
    import Data.Aeson as A
    import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
    import Data.Map (fromList, lookup) import Data.Map (fromList, lookup)
    import Data.Either (Either(..)) import Data.Either (Either(..))
    ...@@ -33,7 +32,7 @@ import Data.Text (Text, unpack) ...@@ -33,7 +32,7 @@ import Data.Text (Text, unpack)
    import Data.Swagger import Data.Swagger
    import Gargantext.Database.Types.Node -- (NodeType(..), Node, Hyperdata(..)) 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 Gargantext.Prelude
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    ...@@ -49,36 +48,10 @@ data NodeTree = NodeTree { _nt_name :: Text ...@@ -49,36 +48,10 @@ data NodeTree = NodeTree { _nt_name :: Text
    } deriving (Show, Read, Generic) } deriving (Show, Read, Generic)
    $(deriveJSON (unPrefix "_nt_") ''NodeTree) $(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 --data Classification = Favorites | MyClassifcation
    ...@@ -127,17 +100,14 @@ type IsTrash = Bool ...@@ -127,17 +100,14 @@ type IsTrash = Bool
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- All the Database is structred like a hierarchical Tree -- 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) deriving (Show, Read, Eq, Generic, Ord)
    instance ToJSON a => ToJSON (Tree a) where $(deriveJSON (unPrefix "_tn_") ''Tree)
    toJSON (TreeN node nodes) =
    object ["node" A..= toJSON node, "children" A..= toJSON nodes]
    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 instance Arbitrary (Tree NodeTree) where
    arbitrary = elements [userTree, userTree] arbitrary = elements [userTree, userTree]
    ...@@ -146,3 +116,33 @@ instance Arbitrary (Tree NodeTree) where ...@@ -146,3 +116,33 @@ instance Arbitrary (Tree NodeTree) where
    -- same as Data.Tree -- same as Data.Tree
    leafT :: a -> Tree a leafT :: a -> Tree a
    leafT x = TreeN x [] 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 ...@@ -25,15 +25,18 @@ Phylomemy was first described in Chavalarias, D., Cointet, J.-P., 2013. Phylomem
    module Gargantext.Core.Types.Phylo where module Gargantext.Core.Types.Phylo where
    import Control.Lens (makeLenses)
    import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
    import Data.Maybe (Maybe) import Data.Maybe (Maybe)
    import Data.Swagger
    import Data.Text (Text) import Data.Text (Text)
    import Data.Time.Clock.POSIX (POSIXTime) import Data.Time.Clock.POSIX (POSIXTime)
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- | Phylo datatype descriptor of a phylomemy -- | Phylo datatype descriptor of a phylomemy
    ...@@ -94,8 +97,24 @@ type PhyloGroupId = (PhyloLevelId, Int) ...@@ -94,8 +97,24 @@ type PhyloGroupId = (PhyloLevelId, Int)
    type Edge = (PhyloGroupId, Weight) type Edge = (PhyloGroupId, Weight)
    type Weight = Double type Weight = Double
    -- | Lenses
    makeLenses ''Phylo
    makeLenses ''PhyloPeriod
    makeLenses ''PhyloLevel
    makeLenses ''PhyloGroup
    -- | JSON instances -- | JSON instances
    $(deriveJSON (unPrefix "_phylo_" ) ''Phylo ) $(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
    $(deriveJSON (unPrefix "_phylo_Period" ) ''PhyloPeriod ) $(deriveJSON (unPrefix "_phylo_Period" ) ''PhyloPeriod )
    $(deriveJSON (unPrefix "_phylo_Level" ) ''PhyloLevel ) $(deriveJSON (unPrefix "_phylo_Level" ) ''PhyloLevel )
    $(deriveJSON (unPrefix "_phylo_Group" ) ''PhyloGroup ) $(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) ...@@ -22,6 +22,7 @@ import Data.Aeson.TH (Options, fieldLabelModifier, omitNothingFields)
    import Data.Aeson.Types (Parser) import Data.Aeson.Types (Parser)
    import Data.Char (toLower) import Data.Char (toLower)
    import Data.Monoid ((<>)) import Data.Monoid ((<>))
    import Data.Swagger.SchemaOptions (SchemaOptions, fromAesonOptions)
    import Text.Read (Read(..),readMaybe) import Text.Read (Read(..),readMaybe)
    ...@@ -32,6 +33,9 @@ unPrefix prefix = defaultOptions ...@@ -32,6 +33,9 @@ unPrefix prefix = defaultOptions
    , omitNothingFields = True , omitNothingFields = True
    } }
    unPrefixSwagger :: String -> SchemaOptions
    unPrefixSwagger = fromAesonOptions . unPrefix
    -- | Lower case leading character -- | Lower case leading character
    unCapitalize :: String -> String unCapitalize :: String -> String
    unCapitalize [] = [] unCapitalize [] = []
    ......
    src/Gargantext/Database.hs
    View file @ 76e11752
    ...@@ -17,9 +17,9 @@ Gargantext's database. ...@@ -17,9 +17,9 @@ Gargantext's database.
    {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
    module Gargantext.Database ( module Gargantext.Database.Utils module Gargantext.Database ( module Gargantext.Database.Utils
    , module Gargantext.Database.Bashql -- , module Gargantext.Database.Bashql
    ) )
    where where
    import Gargantext.Database.Utils (connectGargandb) 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 ...@@ -7,6 +7,7 @@ Maintainer : team@gargantext.org
    Stability : experimental Stability : experimental
    Portability : POSIX Portability : POSIX
    TODO-SECURITY review purpose of this module
    -} -}
    {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
    ......
    src/Gargantext/Database/Bashql.hs
    View file @ 76e11752
    {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
    {-| {-|
    Module : Gargantext.Database.Bashql Module : Gargantext.Database.Bashql
    Description : BASHQL to deal with Gargantext Database. Description : BASHQL to deal with Gargantext Database.
    ...@@ -55,13 +56,15 @@ AMS, and by SIAM. ...@@ -55,13 +56,15 @@ AMS, and by SIAM.
    [3] https://github.com/Gabriel439/Haskell-Turtle-Library [3] https://github.com/Gabriel439/Haskell-Turtle-Library
    TODO-ACCESS: should the checks be done here or before.
    -} -}
    {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
    module Gargantext.Database.Bashql ( get module Gargantext.Database.Bashql () {-( get
    , ls , ls
    , home , home
    , post , post
    ...@@ -71,7 +74,7 @@ module Gargantext.Database.Bashql ( get ...@@ -71,7 +74,7 @@ module Gargantext.Database.Bashql ( get
    , rename , rename
    , tree , tree
    -- , mkCorpus, mkAnnuaire -- , mkCorpus, mkAnnuaire
    ) )-}
    where where
    import Control.Monad.Reader -- (Reader, ask) import Control.Monad.Reader -- (Reader, ask)
    ......
    src/Gargantext/Database/Facet.hs
    View file @ 76e11752
    ...@@ -26,10 +26,22 @@ Portability : POSIX ...@@ -26,10 +26,22 @@ Portability : POSIX
    {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    module Gargantext.Database.Facet module Gargantext.Database.Facet
    ( runViewAuthorsDoc
    , runViewDocuments
    , filterWith
    , Pair(..)
    , Facet(..)
    , FacetDoc
    , FacetDocRead
    , FacetPaired(..)
    , FacetPairedRead
    , OrderBy(..)
    )
    where where
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    import Control.Arrow (returnA) import Control.Arrow (returnA)
    import Control.Lens.TH (makeLensesWith, abbreviatedFields) -- import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    import Data.Aeson (FromJSON, ToJSON) import Data.Aeson (FromJSON, ToJSON)
    import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
    import Data.Either(Either(Left)) import Data.Either(Either(Left))
    ...@@ -41,7 +53,7 @@ import Data.Time (UTCTime) ...@@ -41,7 +53,7 @@ import Data.Time (UTCTime)
    import Data.Time.Segment (jour) import Data.Time.Segment (jour)
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import Gargantext.Core.Types 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.Config (nodeTypeId)
    import Gargantext.Database.Schema.Ngrams import Gargantext.Database.Schema.Ngrams
    import Gargantext.Database.Schema.Node import Gargantext.Database.Schema.Node
    ...@@ -70,9 +82,9 @@ type Title = Text ...@@ -70,9 +82,9 @@ type Title = Text
    -- TODO remove Title -- TODO remove Title
    type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Favorite) (Maybe Double) type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Favorite) (Maybe Double)
    type FacetSources = FacetDoc -- type FacetSources = FacetDoc
    type FacetAuthors = FacetDoc -- type FacetAuthors = FacetDoc
    type FacetTerms = FacetDoc -- type FacetTerms = FacetDoc
    data Facet id created title hyperdata favorite ngramCount = data Facet id created title hyperdata favorite ngramCount =
    ...@@ -99,9 +111,7 @@ $(deriveJSON (unPrefix "_p_") ''Pair) ...@@ -99,9 +111,7 @@ $(deriveJSON (unPrefix "_p_") ''Pair)
    $(makeAdaptorAndInstance "pPair" ''Pair) $(makeAdaptorAndInstance "pPair" ''Pair)
    instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_p_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 3 fieldLabel}
    instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
    arbitrary = Pair <$> arbitrary <*> arbitrary arbitrary = Pair <$> arbitrary <*> arbitrary
    ...@@ -116,9 +126,7 @@ $(deriveJSON (unPrefix "_fp_") ''FacetPaired) ...@@ -116,9 +126,7 @@ $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
    $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired) $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
    instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fp_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    instance ( Arbitrary id instance ( Arbitrary id
    , Arbitrary date , Arbitrary date
    ...@@ -142,7 +150,8 @@ type FacetPairedRead = FacetPaired (Column PGInt4 ) ...@@ -142,7 +150,8 @@ type FacetPairedRead = FacetPaired (Column PGInt4 )
    $(deriveJSON (unPrefix "facetDoc_") ''Facet) $(deriveJSON (unPrefix "facetDoc_") ''Facet)
    -- | Documentation instance -- | Documentation instance
    instance ToSchema FacetDoc instance ToSchema FacetDoc where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
    -- | Mock and Quickcheck instances -- | Mock and Quickcheck instances
    instance Arbitrary FacetDoc where instance Arbitrary FacetDoc where
    ...@@ -158,7 +167,7 @@ instance Arbitrary FacetDoc where ...@@ -158,7 +167,7 @@ instance Arbitrary FacetDoc where
    -- Facets / Views for the Front End -- Facets / Views for the Front End
    -- | Database instances -- | Database instances
    $(makeAdaptorAndInstance "pFacetDoc" ''Facet) $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
    $(makeLensesWith abbreviatedFields ''Facet) -- $(makeLensesWith abbreviatedFields ''Facet)
    type FacetDocRead = Facet (Column PGInt4 ) type FacetDocRead = Facet (Column PGInt4 )
    (Column PGTimestamptz) (Column PGTimestamptz)
    ...@@ -196,6 +205,7 @@ instance Arbitrary OrderBy ...@@ -196,6 +205,7 @@ instance Arbitrary OrderBy
    arbitrary = elements [minBound..maxBound] arbitrary = elements [minBound..maxBound]
    -- TODO-SECURITY check
    runViewAuthorsDoc :: ContactId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc] 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 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
    where where
    ...@@ -236,6 +246,7 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable ...@@ -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 :: CorpusId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
    runViewDocuments cId t o l order = runViewDocuments cId t o l order =
    runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
    ......
    src/Gargantext/Database/Flow.hs
    View file @ 76e11752
    ...@@ -31,6 +31,13 @@ Portability : POSIX ...@@ -31,6 +31,13 @@ Portability : POSIX
    {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
    module Gargantext.Database.Flow -- (flowDatabase, ngrams2list) module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
    ( FlowCmdM
    , flowCorpusFile
    , flowCorpus
    , flowCorpusSearchInDatabase
    , getOrMkRoot
    , getOrMkRootWithCorpus
    )
    where where
    import Prelude (String) import Prelude (String)
    import Data.Either import Data.Either
    ...@@ -45,7 +52,7 @@ import Data.Monoid ...@@ -45,7 +52,7 @@ import Data.Monoid
    import Data.Text (Text, splitOn, intercalate) import Data.Text (Text, splitOn, intercalate)
    import GHC.Show (Show) import GHC.Show (Show)
    import Gargantext.API.Ngrams (HasRepoVar) 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 (Lang(..))
    import Gargantext.Core.Types (NodePoly(..), Terms(..)) import Gargantext.Core.Types (NodePoly(..), Terms(..))
    import Gargantext.Core.Types.Individu (Username) import Gargantext.Core.Types.Individu (Username)
    ...@@ -99,30 +106,32 @@ getDataApi lang limit (ApiIsidoreQuery q) = Isidore.get lang limit (Just q) Noth ...@@ -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) 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] => Username -> Either CorpusName [CorpusId]
    -> TermType Lang -> TermType Lang
    -> Maybe Limit -> Maybe Limit
    -> ApiQuery -> ApiQuery
    -> m CorpusId -> 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 docs <- liftIO $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
    flowCorpus u n tt docs 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 => 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]]) docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
    flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
    -- UNUSED
    flowCorpusDebat :: FlowCmdM env err m _flowCorpusDebat :: FlowCmdM env err m
    => Username -> Either CorpusName [CorpusId] => Username -> Either CorpusName [CorpusId]
    -> Limit -> FilePath -> Limit -> FilePath
    -> m CorpusId -> m CorpusId
    flowCorpusDebat u n l fp = do _flowCorpusDebat u n l fp = do
    docs <- liftIO ( splitEvery 500 docs <- liftIO ( splitEvery 500
    <$> take l <$> take l
    <$> readFile' fp <$> readFile' fp
    ...@@ -151,19 +160,22 @@ flowCorpusSearchInDatabase u la q = do ...@@ -151,19 +160,22 @@ flowCorpusSearchInDatabase u la q = do
    flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids 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 => Username -> Lang -> Text -> m CorpusId
    flowCorpusSearchInDatabaseApi u la q = do _flowCorpusSearchInDatabaseApi u la q = do
    (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster (Left "") (Nothing :: Maybe HyperdataCorpus) (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster (Left "") (Nothing :: Maybe HyperdataCorpus)
    ids <- map fst <$> searchInDatabase cId (stemIt q) ids <- map fst <$> searchInDatabase cId (stemIt q)
    flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- | TODO improve the needed type to create/update a corpus -- | TODO improve the needed type to create/update a corpus
    {- UNUSED
    data UserInfo = Username Text data UserInfo = Username Text
    | UserId NodeId | UserId NodeId
    data CorpusInfo = CorpusName Lang Text data CorpusInfo = CorpusName Lang Text
    | CorpusId Lang NodeId | CorpusId Lang NodeId
    -}
    flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c) flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)
    ......
    src/Gargantext/Database/Flow/Pairing.hs
    View file @ 76e11752
    ...@@ -16,6 +16,7 @@ Portability : POSIX ...@@ -16,6 +16,7 @@ Portability : POSIX
    -- {-# LANGUAGE Arrows #-} -- {-# LANGUAGE Arrows #-}
    module Gargantext.Database.Flow.Pairing module Gargantext.Database.Flow.Pairing
    (pairing)
    where where
    --import Debug.Trace (trace) --import Debug.Trace (trace)
    ......
    src/Gargantext/Database/Node/Contact.hs
    View file @ 76e11752
    ...@@ -22,12 +22,12 @@ module Gargantext.Database.Node.Contact ...@@ -22,12 +22,12 @@ module Gargantext.Database.Node.Contact
    import Control.Lens (makeLenses) import Control.Lens (makeLenses)
    import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
    import Data.Swagger (ToSchema) import Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
    import Data.Text (Text) import Data.Text (Text)
    import Data.Time (UTCTime) import Data.Time (UTCTime)
    import Database.PostgreSQL.Simple.FromField (FromField, fromField) import Database.PostgreSQL.Simple.FromField (FromField, fromField)
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Core.Types (Name) import Gargantext.Core.Types (Name)
    import Gargantext.Database.Schema.Node (NodeWrite, node) import Gargantext.Database.Schema.Node (NodeWrite, node)
    import Gargantext.Database.Types.Node (Node,Hyperdata,NodeType(..), UserId, AnnuaireId) import Gargantext.Database.Types.Node (Node,Hyperdata,NodeType(..), UserId, AnnuaireId)
    ...@@ -105,16 +105,22 @@ nodeContactW maybeName maybeContact aId = ...@@ -105,16 +105,22 @@ nodeContactW maybeName maybeContact aId =
    contact = maybe arbitraryHyperdataContact identity maybeContact contact = maybe arbitraryHyperdataContact identity maybeContact
    -- | Main instances of Contact -- | ToSchema instances
    instance ToSchema HyperdataContact instance ToSchema HyperdataContact where
    instance ToSchema ContactWho declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hc_")
    instance ToSchema ContactWhere instance ToSchema ContactWho where
    instance ToSchema ContactTouch 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 instance Arbitrary HyperdataContact where
    arbitrary = elements [HyperdataContact Nothing Nothing [] Nothing Nothing Nothing Nothing Nothing] arbitrary = elements [HyperdataContact Nothing Nothing [] Nothing Nothing Nothing Nothing Nothing]
    -- | Specific Gargantext instance -- | Specific Gargantext instance
    instance Hyperdata HyperdataContact instance Hyperdata HyperdataContact
    ......
    src/Gargantext/Database/Node/Update.hs
    View file @ 76e11752
    ...@@ -41,6 +41,7 @@ data Update = Rename NodeId Name ...@@ -41,6 +41,7 @@ data Update = Rename NodeId Name
    unOnly :: Only a -> a unOnly :: Only a -> a
    unOnly (Only a) = a unOnly (Only a) = a
    -- TODO-ACCESS
    update :: Update -> Cmd err [Int] update :: Update -> Cmd err [Int]
    update (Rename nId name) = map unOnly <$> runPGSQuery "UPDATE nodes SET name=? where id=? returning id" update (Rename nId name) = map unOnly <$> runPGSQuery "UPDATE nodes SET name=? where id=? returning id"
    (DT.take 255 name,nId) (DT.take 255 name,nId)
    ......
    src/Gargantext/Database/TextSearch.hs
    View file @ 76e11752
    ...@@ -82,6 +82,7 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond ...@@ -82,6 +82,7 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
    type AuthorName = Text type AuthorName = Text
    -- | TODO Optim: Offset and Limit in the Query -- | 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 :: 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) 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)) <$> 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 ...@@ -94,6 +95,7 @@ searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop
    maybePair (Pair Nothing _) = Nothing maybePair (Pair Nothing _) = Nothing
    maybePair (Pair (Just p_id) (Just p_label)) = Just $ Pair p_id p_label 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' :: 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 searchInCorpusWithContacts' cId q o l order = runOpaQuery $ queryInCorpusWithContacts cId q' o l order
    where 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 ...@@ -16,7 +16,15 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
    {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE RankNTypes #-} {-# 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.Lens (Prism', (#), (^..), at, each, _Just, to)
    import Control.Monad.Error.Class (MonadError(throwError)) import Control.Monad.Error.Class (MonadError(throwError))
    ...@@ -103,7 +111,21 @@ dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGS ...@@ -103,7 +111,21 @@ dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGS
    SELECT * from tree; SELECT * from tree;
    |] (Only rootId) |] (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) ...@@ -41,9 +41,8 @@ import Data.ByteString.Lazy (ByteString)
    import Data.Either import Data.Either
    import Data.Eq (Eq) import Data.Eq (Eq)
    import Data.Monoid (mempty) import Data.Monoid (mempty)
    import Data.Text (Text, unpack, pack) import Data.Text (Text, unpack)
    import Data.Time (UTCTime) import Data.Time (UTCTime)
    import Data.Time.Segment (jour, timesAfter, Granularity(D))
    import Data.Swagger import Data.Swagger
    import Text.Read (read) import Text.Read (read)
    ...@@ -55,9 +54,11 @@ import Servant ...@@ -55,9 +54,11 @@ import Servant
    import Test.QuickCheck.Arbitrary import Test.QuickCheck.Arbitrary
    import Test.QuickCheck (elements) import Test.QuickCheck (elements)
    import Test.QuickCheck.Instances.Time ()
    import Test.QuickCheck.Instances.Text ()
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Viz.Phylo (Phylo) import Gargantext.Viz.Phylo (Phylo)
    --import Gargantext.Database.Utils --import Gargantext.Database.Utils
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    ...@@ -133,12 +134,6 @@ type MasterUserId = UserId ...@@ -133,12 +134,6 @@ type MasterUserId = UserId
    id2int :: NodeId -> Int id2int :: NodeId -> Int
    id2int (NodeId n) = n 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 data Status = Status { status_failed :: !Int
    , status_succeeded :: !Int , status_succeeded :: !Int
    ...@@ -273,18 +268,16 @@ instance Arbitrary Event where ...@@ -273,18 +268,16 @@ instance Arbitrary Event where
    arbitrary = Event <$> arbitrary <*> arbitrary <*> arbitrary arbitrary = Event <$> arbitrary <*> arbitrary <*> arbitrary
    instance ToSchema Event where 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) data Resource = Resource { resource_path :: !(Maybe Text)
    , resource_scraper :: !(Maybe Text) , resource_scraper :: !(Maybe Text)
    , resource_query :: !(Maybe Text) , resource_query :: !(Maybe Text)
    , resource_events :: !([Event]) , resource_events :: !([Event])
    , resource_status :: !Status , resource_status :: !Status
    , resource_date :: !UTCTime' , resource_date :: !UTCTime
    } deriving (Show, Generic) } deriving (Show, Generic)
    $(deriveJSON (unPrefix "resource_") ''Resource) $(deriveJSON (unPrefix "resource_") ''Resource)
    ...@@ -297,7 +290,7 @@ instance Arbitrary Resource where ...@@ -297,7 +290,7 @@ instance Arbitrary Resource where
    <*> arbitrary <*> arbitrary
    instance ToSchema Resource where instance ToSchema Resource where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "resource_")
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    data HyperdataUser = HyperdataUser { hyperdataUser_language :: Maybe Text data HyperdataUser = HyperdataUser { hyperdataUser_language :: Maybe Text
    ...@@ -534,17 +527,20 @@ docExample :: ByteString ...@@ -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}" 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 instance ToSchema HyperdataCorpus where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "hyperdataCorpus_") proxy
    & mapped.schema.description ?~ "a corpus" & mapped.schema.description ?~ "a corpus"
    & mapped.schema.example ?~ toJSON hyperdataCorpus & mapped.schema.example ?~ toJSON hyperdataCorpus
    instance ToSchema HyperdataAnnuaire where instance ToSchema HyperdataAnnuaire where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "hyperdataAnnuaire_") proxy
    & mapped.schema.description ?~ "an annuaire" & mapped.schema.description ?~ "an annuaire"
    & mapped.schema.example ?~ toJSON hyperdataAnnuaire & mapped.schema.example ?~ toJSON hyperdataAnnuaire
    instance ToSchema HyperdataDocument where instance ToSchema HyperdataDocument where
    declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "_hyperdataDocument_") proxy
    & mapped.schema.description ?~ "a document" & mapped.schema.description ?~ "a document"
    & mapped.schema.example ?~ toJSON hyperdataDocument & mapped.schema.example ?~ toJSON hyperdataDocument
    ...@@ -560,14 +556,16 @@ instance ToSchema hyperdata => ...@@ -560,14 +556,16 @@ instance ToSchema hyperdata =>
    (Maybe UserId) (Maybe UserId)
    ParentId NodeName ParentId NodeName
    UTCTime hyperdata UTCTime hyperdata
    ) ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_node_")
    instance ToSchema hyperdata => instance ToSchema hyperdata =>
    ToSchema (NodePoly NodeId NodeTypeId ToSchema (NodePoly NodeId NodeTypeId
    UserId UserId
    (Maybe ParentId) NodeName (Maybe ParentId) NodeName
    UTCTime hyperdata UTCTime hyperdata
    ) ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_node_")
    instance ToSchema hyperdata => instance ToSchema hyperdata =>
    ...@@ -575,16 +573,19 @@ instance ToSchema hyperdata => ...@@ -575,16 +573,19 @@ instance ToSchema hyperdata =>
    (Maybe UserId) (Maybe UserId)
    ParentId NodeName ParentId NodeName
    UTCTime hyperdata (Maybe TSVector) UTCTime hyperdata (Maybe TSVector)
    ) ) where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ns_")
    instance ToSchema hyperdata => instance ToSchema hyperdata =>
    ToSchema (NodePolySearch NodeId NodeTypeId ToSchema (NodePolySearch NodeId NodeTypeId
    UserId UserId
    (Maybe ParentId) NodeName (Maybe ParentId) NodeName
    UTCTime hyperdata (Maybe TSVector) 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 ...@@ -24,7 +24,7 @@ import Data.Swagger
    import Data.Text (Text, pack) import Data.Text (Text, pack)
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import GHC.IO (FilePath) import GHC.IO (FilePath)
    import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
    import Gargantext.Core.Types (ListId) import Gargantext.Core.Types (ListId)
    import Gargantext.Database.Types.Node (NodeId) import Gargantext.Database.Types.Node (NodeId)
    import Gargantext.Prelude import Gargantext.Prelude
    ...@@ -57,9 +57,7 @@ data Node = Node { node_size :: Int ...@@ -57,9 +57,7 @@ data Node = Node { node_size :: Int
    deriving (Show, Generic) deriving (Show, Generic)
    $(deriveJSON (unPrefix "node_") ''Node) $(deriveJSON (unPrefix "node_") ''Node)
    instance ToSchema Node where instance ToSchema Node where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
    data Edge = Edge { edge_source :: Text data Edge = Edge { edge_source :: Text
    ...@@ -71,9 +69,7 @@ data Edge = Edge { edge_source :: Text ...@@ -71,9 +69,7 @@ data Edge = Edge { edge_source :: Text
    deriving (Show, Generic) deriving (Show, Generic)
    $(deriveJSON (unPrefix "edge_") ''Edge) $(deriveJSON (unPrefix "edge_") ''Edge)
    instance ToSchema Edge where instance ToSchema Edge where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
    --------------------------------------------------------------- ---------------------------------------------------------------
    data LegendField = LegendField { _lf_id :: Int data LegendField = LegendField { _lf_id :: Int
    ...@@ -83,9 +79,7 @@ data LegendField = LegendField { _lf_id :: Int ...@@ -83,9 +79,7 @@ data LegendField = LegendField { _lf_id :: Int
    $(deriveJSON (unPrefix "_lf_") ''LegendField) $(deriveJSON (unPrefix "_lf_") ''LegendField)
    instance ToSchema LegendField where instance ToSchema LegendField where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    makeLenses ''LegendField makeLenses ''LegendField
    -- --
    ...@@ -97,9 +91,7 @@ data GraphMetadata = GraphMetadata { _gm_title :: Text -- title of the grap ...@@ -97,9 +91,7 @@ data GraphMetadata = GraphMetadata { _gm_title :: Text -- title of the grap
    deriving (Show, Generic) deriving (Show, Generic)
    $(deriveJSON (unPrefix "_gm_") ''GraphMetadata) $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
    instance ToSchema GraphMetadata where instance ToSchema GraphMetadata where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
    makeLenses ''GraphMetadata makeLenses ''GraphMetadata
    ...@@ -112,10 +104,7 @@ $(deriveJSON (unPrefix "_graph_") ''Graph) ...@@ -112,10 +104,7 @@ $(deriveJSON (unPrefix "_graph_") ''Graph)
    makeLenses ''Graph makeLenses ''Graph
    instance ToSchema Graph where instance ToSchema Graph where
    declareNamedSchema = declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
    genericDeclareNamedSchema
    defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 7 fieldLabel}
    -- | Intances for the mack -- | Intances for the mack
    instance Arbitrary Graph where instance Arbitrary Graph where
    ......
    src/Gargantext/Viz/Phylo.hs
    View file @ 76e11752
    ...@@ -37,10 +37,11 @@ import Data.Text (Text) ...@@ -37,10 +37,11 @@ import Data.Text (Text)
    import Data.Set (Set) import Data.Set (Set)
    import Data.Map (Map) import Data.Map (Map)
    import Data.Vector (Vector) import Data.Vector (Vector)
    import Data.Swagger
    --import Data.Time.Clock.POSIX (POSIXTime) --import Data.Time.Clock.POSIX (POSIXTime)
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    --import Gargantext.Database.Schema.Ngrams (NgramsId) --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.Text.Context (TermList)
    import Gargantext.Prelude import Gargantext.Prelude
    ...@@ -517,6 +518,57 @@ $(deriveJSON (unPrefix "_pn_" ) ''PhyloNode ) ...@@ -517,6 +518,57 @@ $(deriveJSON (unPrefix "_pn_" ) ''PhyloNode )
    $(deriveJSON defaultOptions ''Filiation ) $(deriveJSON defaultOptions ''Filiation )
    $(deriveJSON defaultOptions ''EdgeType ) $(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 | -- -- | TODO XML instances | --
    ......
    src/Gargantext/Viz/Phylo/API.hs
    View file @ 76e11752
    ...@@ -29,7 +29,6 @@ import qualified Data.ByteString as DB ...@@ -29,7 +29,6 @@ import qualified Data.ByteString as DB
    import qualified Data.ByteString.Lazy as DBL import qualified Data.ByteString.Lazy as DBL
    import Data.Swagger import Data.Swagger
    import Gargantext.API.Types import Gargantext.API.Types
    import Gargantext.API.Utils (swaggerOptions)
    import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId) import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId)
    import Gargantext.Database.Schema.Node (insertNodes, nodePhyloW, getNodePhylo) import Gargantext.Database.Schema.Node (insertNodes, nodePhyloW, getNodePhylo)
    import Gargantext.Database.Types.Node -- (NodePhylo(..)) import Gargantext.Database.Types.Node -- (NodePhylo(..))
    ...@@ -153,33 +152,7 @@ instance Arbitrary Phylo ...@@ -153,33 +152,7 @@ instance Arbitrary Phylo
    where where
    arbitrary = elements [phylo] 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 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 ToParamSchema Order
    instance FromHttpApiData Order instance FromHttpApiData Order
    ...@@ -213,13 +186,6 @@ instance FromHttpApiData Sort ...@@ -213,13 +186,6 @@ instance FromHttpApiData Sort
    parseUrlPiece = readTextData parseUrlPiece = readTextData
    instance ToParamSchema Sort instance ToParamSchema Sort
    instance ToSchema Proximity
    where
    declareNamedSchema = genericDeclareNamedSchemaUnrestricted
    $ swaggerOptions ""
    instance FromHttpApiData [Tagger] instance FromHttpApiData [Tagger]
    where where
    parseUrlPiece = readTextData parseUrlPiece = readTextData
    ......
    stack.yaml
    View file @ 76e11752
    ...@@ -6,7 +6,7 @@ packages: ...@@ -6,7 +6,7 @@ packages:
    docker: docker:
    enable: false enable: false
    repo: 'cgenie/stack-build:lts-12.26' repo: 'fpco/stack-build:lts-14.6-garg'
    allow-newer: true allow-newer: true
    extra-deps: 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