Secure API with JWT auth. Part 1

parent 365c0e0d
......@@ -30,7 +30,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument)
import Gargantext.Database.Schema.User (insertUsersDemo)
import Gargantext.Text.Terms (TermType(..))
import Gargantext.Core (Lang(..))
import Gargantext.API -- (GargError)
import Gargantext.API.Types (GargError)
import Gargantext.API.Node () -- instances
import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
import System.Environment (getArgs)
......
......@@ -28,7 +28,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument, RootId)
import Gargantext.Database.Schema.User (insertUsersDemo, UserId)
import Gargantext.Text.Terms (TermType(..))
import Gargantext.Core (Lang(..))
import Gargantext.API -- (GargError)
import Gargantext.API.Types (GargError)
import Gargantext.API.Node () -- instances
import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
--import Gargantext.Text.Corpus.Parsers.GrandDebat (readFile, GrandDebatReference(..))
......
from fpco/stack-build:lts-12.26
from fpco/stack-build:lts-14.6
RUN apt-get update && \
apt-get install -y git libigraph0-dev && \
......
......@@ -4,6 +4,6 @@ docker rm --volumes dbgarg || :
export PGPASSWORD="$(grep DB_PASS gargantext.ini | \awk '{print $3}')"
docker run --name dbgarg -e POSTGRES_USER=gargantua -e POSTGRES_DB=gargandbV5 -e POSTGRES_PASSWORD=${PGPASSWORD} -d postgres
sleep 3
docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 < src/Gargantext/Database/Schema/schema.sql
docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 < devops/postgres/schema.sql
#docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 < gargantext.dump
#docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres dropdb -h postgres -U gargantua gargandbV5
......@@ -33,6 +33,7 @@ library:
# - Gargantext.API.Orchestrator
- Gargantext.API.Search
- Gargantext.API.Settings
- Gargantext.API.Types
- Gargantext.Core
- Gargantext.Core.Types
- Gargantext.Core.Types.Main
......@@ -130,7 +131,7 @@ library:
- hlcm
- ini
- insert-ordered-containers
- jose-jwt
- jose
# - kmeans-vector
- json-stream
- KMP
......@@ -160,6 +161,7 @@ library:
- simple-reflect
- cereal # (IGraph)
- singletons # (IGraph)
- quickcheck-instances
- random
- rake
- regex-compat
......@@ -169,6 +171,8 @@ library:
- semigroups
- servant
- servant-auth
- servant-auth-server >= 0.4.4.0
- servant-auth-swagger
- servant-blaze
- servant-client
# - servant-job
......
......@@ -55,6 +55,9 @@ import Network.Wai
import Network.Wai.Handler.Warp hiding (defaultSettings)
import Servant
import Servant.Auth as SA
import Servant.Auth.Server (AuthResult(..))
import Servant.Auth.Swagger ()
import Servant.HTML.Blaze (HTML)
--import Servant.Mock (mock)
--import Servant.Job.Server (WithCallbacks)
......@@ -68,7 +71,7 @@ import Text.Blaze.Html (Html)
--import Gargantext.API.Swagger
--import Gargantext.Database.Node.Contact (HyperdataContact)
import Gargantext.API.Auth (AuthRequest, AuthResponse, auth)
import Gargantext.API.Auth (AuthRequest, AuthResponse, AuthenticatedUser(..), AuthContext, auth)
import Gargantext.API.Count ( CountAPI, count, Query)
import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, TableNgramsApi, apiNgramsTableDoc)
......@@ -76,9 +79,6 @@ import Gargantext.API.Node
import Gargantext.API.Search (SearchPairsAPI, searchPairs)
import Gargantext.API.Types
import qualified Gargantext.API.Corpus.New as New
import Gargantext.Core.Types (HasInvalidError(..))
import Gargantext.Database.Schema.Node (HasNodeError(..), NodeError)
import Gargantext.Database.Tree (HasTreeError(..), TreeError)
import Gargantext.Database.Types.Node
import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
import Gargantext.Database.Utils (HasConnection)
......@@ -109,24 +109,8 @@ import Network.HTTP.Types hiding (Query)
import Gargantext.API.Settings
data GargError
= GargNodeError NodeError
| GargTreeError TreeError
| GargInvalidError Validation
deriving (Show)
makePrisms ''GargError
instance HasNodeError GargError where
_NodeError = _GargNodeError
instance HasInvalidError GargError where
_InvalidError = _GargInvalidError
instance HasTreeError GargError where
_TreeError = _GargTreeError
showAsServantErr :: Show a => a -> ServerError
showAsServantErr :: GargError -> ServerError
showAsServantErr (GargServerError err) = err
showAsServantErr a = err500 { errBody = BL8.pack $ show a }
fireWall :: Applicative f => Request -> FireWall -> f Bool
......@@ -231,15 +215,21 @@ type GargAPI' =
"auth" :> Summary "AUTH API"
:> ReqBody '[JSON] AuthRequest
:> Post '[JSON] AuthResponse
-- TODO-ACCESS here we want to request a particular header for
-- auth and capabilities.
:<|> GargPrivateAPI
type GargPrivateAPI = SA.Auth '[SA.JWT] AuthenticatedUser :> GargPrivateAPI'
type GargPrivateAPI' =
-- Roots endpoint
:<|> "user" :> Summary "First user endpoint"
"user" :> Summary "First user endpoint"
:> Roots
-- Node endpoint
:<|> "node" :> Summary "Node endpoint"
:> Capture "id" NodeId :> NodeAPI HyperdataAny
-- Corpus endpoint
:<|> "corpus":> Summary "Corpus endpoint"
:> Capture "id" CorpusId :> NodeAPI HyperdataCorpus
......@@ -290,6 +280,10 @@ type SwaggerFrontAPI = SwaggerAPI :<|> FrontEndAPI
type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
-- This is the concrete monad. It needs to be used as little as possible,
-- instead, prefer GargServer, GargServerT, GargServerC.
type GargServerM env err = ReaderT env (ExceptT err IO)
---------------------------------------------------------------------
-- | Server declarations
......@@ -298,19 +292,28 @@ server :: forall env. (HasConnection env, HasRepo env, HasSettings env)
server env = do
-- orchestrator <- scrapyOrchestrator env
pure $ swaggerFront
:<|> hoistServer (Proxy :: Proxy GargAPI) transform serverGargAPI
:<|> hoistServerWithContext (Proxy :: Proxy GargAPI) (Proxy :: Proxy AuthContext) transform serverGargAPI
:<|> serverStatic
where
transform :: forall a. ReaderT env (ExceptT GargError IO) a -> Handler a
transform :: forall a. GargServerM env GargError a -> Handler a
transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
serverGargAPI :: GargServer GargAPI
serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
serverGargAPI -- orchestrator
= auth
:<|> roots
:<|> nodeAPI (Proxy :: Proxy HyperdataAny) fakeUserId
:<|> nodeAPI (Proxy :: Proxy HyperdataCorpus) fakeUserId
:<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire) fakeUserId
= auth :<|> serverPrivateGargAPI
-- :<|> orchestrator
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.
serverPrivateGargAPI' :: AuthenticatedUser -> GargServer GargPrivateAPI'
serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
= roots
:<|> nodeAPI (Proxy :: Proxy HyperdataAny) uid
:<|> nodeAPI (Proxy :: Proxy HyperdataCorpus) uid
:<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire) uid
:<|> apiNgramsTableDoc
:<|> nodesAPI
:<|> count -- TODO: undefined
......@@ -318,10 +321,7 @@ serverGargAPI -- orchestrator
:<|> graphAPI -- TODO: mock
:<|> treeAPI
:<|> New.api
:<|> New.info fakeUserId
-- :<|> orchestrator
where
fakeUserId = 2 -- TODO, byDefault user1 (if users automatically generated with inserUsersDemo)
:<|> New.info uid
serverStatic :: Server (Get '[HTML] Html)
serverStatic = $(do
......@@ -341,7 +341,13 @@ swaggerFront = schemaUiServer swaggerDoc
---------------------------------------------------------------------
makeApp :: (HasConnection env, HasRepo env, HasSettings env)
=> env -> IO Application
makeApp = fmap (serve api) . server
makeApp env = serveWithContext api cfg <$> server env
where
cfg :: Servant.Context AuthContext
cfg = env ^. settings . jwtSettings
:. env ^. settings . cookieSettings
-- :. authCheck env
:. EmptyContext
--appMock :: Application
--appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
......
......@@ -16,6 +16,8 @@ Main authorisation of Gargantext are managed in this module
-- 2: Implement the Auth API backend
https://github.com/haskell-servant/servant-auth
TODO-ACCESS Critical
-}
{-# LANGUAGE NoImplicitPrelude #-}
......@@ -28,15 +30,22 @@ Main authorisation of Gargantext are managed in this module
module Gargantext.API.Auth
where
import Control.Lens (view)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson.TH (deriveJSON)
import Data.List (elem)
import Data.Swagger
import Data.Text (Text, reverse)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Encoding (decodeUtf8)
import GHC.Generics (Generic)
import Servant.Auth.Server
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.API.Settings
import Gargantext.API.Types (HasJoseError(..), joseError)
import Gargantext.Database.Root (getRoot)
import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId)
import Gargantext.Database.Utils (Cmd)
import Gargantext.Database.Utils (Cmd', HasConnection)
import Gargantext.Prelude hiding (reverse)
import Test.QuickCheck (elements, oneof)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
......@@ -74,15 +83,30 @@ type TreeId = NodeId
data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
deriving (Eq)
checkAuthRequest :: Username -> Password -> Cmd err CheckAuth
makeTokenForUser :: (HasSettings env, HasJoseError err)
=> NodeId -> Cmd' env err Token
makeTokenForUser uid = do
jwtS <- view $ settings . jwtSettings
e <- liftIO $ makeJWT (AuthenticatedUser uid) jwtS Nothing
-- TODO-SECURITY here we can implement token expiration ^^.
either joseError (pure . toStrict . decodeUtf8) e
-- TODO not sure about the encoding...
checkAuthRequest :: (HasSettings env, HasConnection env, HasJoseError err)
=> Username -> Password -> Cmd' env err CheckAuth
checkAuthRequest u p
| not (u `elem` arbitraryUsername) = pure InvalidUser
| u /= reverse p = pure InvalidPassword
| otherwise = do
muId <- getRoot "user1"
pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
auth :: AuthRequest -> Cmd err AuthResponse
muId <- head <$> getRoot "user1" -- TODO user1 hard-coded
case _node_id <$> muId of
Nothing -> pure InvalidUser
Just uid -> do
token <- makeTokenForUser uid
pure $ Valid token uid
auth :: (HasSettings env, HasConnection env, HasJoseError err)
=> AuthRequest -> Cmd' env err AuthResponse
auth (AuthRequest u p) = do
checkAuthRequest' <- checkAuthRequest u p
case checkAuthRequest' of
......@@ -90,9 +114,34 @@ auth (AuthRequest u p) = do
InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
Valid to trId -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
newtype AuthenticatedUser = AuthenticatedUser
{ _au_id :: NodeId
} deriving (Generic)
$(deriveJSON (unPrefix "_au_") ''AuthenticatedUser)
instance ToSchema AuthenticatedUser
instance ToJWT AuthenticatedUser
instance FromJWT AuthenticatedUser
--type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
-- TODO-SECURITY why is the CookieSettings necessary?
type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
{-
instance FromBasicAuthData AuthenticatedUser where
fromBasicAuthData authData authCheckFunction = authCheckFunction authData
authCheck :: forall env. env
-> BasicAuthData
-> IO (AuthResult AuthenticatedUser)
authCheck _env (BasicAuthData login password) = pure $
maybe Indefinite Authenticated $ TODO
-}
-- | Instances
$(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
instance ToSchema AuthRequest
instance ToSchema AuthRequest -- TODO-SWAGGER unPrefix
instance Arbitrary AuthRequest where
arbitrary = elements [ AuthRequest u p
......@@ -101,20 +150,20 @@ instance Arbitrary AuthRequest where
]
$(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
instance ToSchema AuthResponse
instance ToSchema AuthResponse -- TODO-SWAGGER unPrefix
instance Arbitrary AuthResponse where
arbitrary = oneof [ AuthResponse Nothing . Just <$> arbitrary
, flip AuthResponse Nothing . Just <$> arbitrary ]
$(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
instance ToSchema AuthInvalid
instance ToSchema AuthInvalid -- TODO-SWAGGER unPrefix
instance Arbitrary AuthInvalid where
arbitrary = elements [ AuthInvalid m
| m <- [ "Invalid user", "Invalid password"]
]
$(deriveJSON (unPrefix "_authVal_") ''AuthValid)
instance ToSchema AuthValid
instance ToSchema AuthValid -- TODO-SWAGGER unPrefix
instance Arbitrary AuthValid where
arbitrary = elements [ AuthValid to tr
| to <- ["token0", "token1"]
......
......@@ -70,6 +70,8 @@ type Api = Summary "New Corpus endpoint"
:<|> Get '[JSON] ApiInfo
-- | TODO manage several apis
-- TODO-ACCESS
-- TODO this is only the POST
api :: (FlowCmdM env err m) => Query -> m CorpusId
api (Query q _ as) = do
cId <- case head as of
......
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-|
Module : Gargantext.API.Ngrams
Description : Server API
......@@ -32,6 +33,52 @@ add get
{-# OPTIONS -fno-warn-orphans #-}
module Gargantext.API.Ngrams
( TableNgramsApi
, TableNgramsApiGet
, TableNgramsApiPut
, TableNgramsApiPost
, getTableNgrams
, putListNgrams
, tableNgramsPost
, apiNgramsTableCorpus
, apiNgramsTableDoc
, NgramsStatePatch
, NgramsTablePatch
, NgramsElement
, mkNgramsElement
, mergeNgramsElement
, RootParent(..)
, MSet
, mSetFromList
, mSetToList
, Repo(..)
, r_version
, r_state
, NgramsRepo
, NgramsRepoElement(..)
, saveRepo
, initRepo
, RepoEnv(..)
, renv_var
, renv_lock
, TabType(..)
, ngramsTypeFromTabType
, HasRepoVar(..)
, HasRepoSaver(..)
, HasRepo(..)
, RepoCmdM
, QueryParamR
, TODO(..)
)
where
-- import Debug.Trace (trace)
......@@ -798,12 +845,14 @@ putListNgrams listId ngramsType nes = do
where
m = Map.fromList $ (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) <$> nes
-- TODO-ACCESS check
tableNgramsPost :: RepoCmdM env err m => TabType -> NodeId -> Maybe ListType -> [NgramsTerm] -> m ()
tableNgramsPost tabType listId mayList =
putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
-- Apply the given patch to the DB and returns the patch to be applied on the
-- client.
-- TODO-ACCESS check
tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
=> TabType -> ListId
-> Versioned NgramsTablePatch
......
......@@ -33,6 +33,10 @@ import qualified Data.Set as Set
type RootTerm = Text
-- TODO-ACCESS: We want to do the security check before entering here.
-- Add a static capability parameter would be nice.
-- Ideally this is the access to `repoVar` which needs to
-- be properly guarded.
getListNgrams :: RepoCmdM env err m
=> [ListId] -> NgramsType
-> m (Map Text NgramsRepoElement)
......
......@@ -7,6 +7,8 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-- TODO-SECURITY: Critical
-- TODO-ACCESS: CanGetNode
-- TODO-EVENTS: No events as this is a read only query.
Node API
......
......@@ -6,6 +6,8 @@ License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
TODO-SECURITY: Critical
-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
......@@ -40,16 +42,15 @@ import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Either (either)
import Data.Text
import Data.Text.Encoding (encodeUtf8)
--import Data.Text.Encoding (encodeUtf8)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Servant
import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings, defaultCookieSettings, readKey, writeKey)
import Servant.Client (BaseUrl, parseBaseUrl)
--import Servant.Job.Async (newJobEnv, defaultSettings)
import Web.HttpApiData (parseUrlPiece)
import qualified Jose.Jwk as Jose
import qualified Jose.Jwa as Jose
import Control.Concurrent
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
......@@ -77,7 +78,8 @@ data Settings = Settings
, _logLevelLimit :: LogLevel -- log level from the monad-logger package
-- , _dbServer :: Text
-- ^ this is not used yet
, _jwtSecret :: Jose.Jwk -- key from the jose-jwt package
, _jwtSettings :: JWTSettings
, _cookieSettings :: CookieSettings
, _sendLoginEmails :: SendEmailType
, _scrapydUrl :: BaseUrl
, _fileFolder :: FilePath
......@@ -89,29 +91,22 @@ class HasSettings env where
settings :: Getter env Settings
parseJwk :: Text -> Jose.Jwk
parseJwk secretStr = jwk
where
secretBs = encodeUtf8 secretStr
jwk = Jose.SymmetricJwk secretBs
Nothing
Nothing
(Just $ Jose.Signed Jose.HS256)
devSettings :: Settings
devSettings = Settings
devSettings :: FilePath -> IO Settings
devSettings jwkFile = do
jwkExists <- doesFileExist jwkFile
when (not jwkExists) $ writeKey jwkFile
jwk <- readKey jwkFile
pure $ Settings
{ _allowedOrigin = "http://localhost:8008"
, _allowedHost = "localhost:3000"
, _appPort = 3000
, _logLevelLimit = LevelDebug
-- , _dbServer = "localhost"
-- generate with dd if=/dev/urandom bs=1 count=32 | base64
-- make sure jwtSecret differs between development and production, because you do not want
-- your production key inside source control.
, _jwtSecret = parseJwk "MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
, _sendLoginEmails = LogEmailToConsole
, _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
, _fileFolder = "data"
, _cookieSettings = defaultCookieSettings -- TODO-SECURITY tune
, _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
}
......@@ -232,10 +227,13 @@ readRepoEnv = do
saver <- mkRepoSaver mvar
pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
devJwkFile :: FilePath
devJwkFile = "dev.jwk"
newEnv :: PortNumber -> FilePath -> IO Env
newEnv port file = do
manager <- newTlsManager
settings <- pure (devSettings & appPort .~ port) -- TODO read from 'file'
settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
when (port /= settings ^. appPort) $
panic "TODO: conflicting settings of port"
......@@ -295,10 +293,11 @@ withDevEnv iniPath k = do
param <- databaseParameters iniPath
conn <- connect param
repo <- readRepoEnv
setts <- devSettings devJwkFile
pure $ DevEnv
{ _dev_env_conn = conn
, _dev_env_repo = repo
, _dev_env_settings = devSettings
, _dev_env_settings = setts
}
-- | Run Cmd Sugar for the Repl (GHCI)
......
......@@ -10,13 +10,26 @@ Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Gargantext.API.Types
where
import Control.Lens (Prism', (#))
import Control.Lens.TH (makePrisms)
import Control.Monad.Error.Class (MonadError(throwError))
import Crypto.JOSE.Error as Jose
import Data.Validity
import Servant
import Gargantext.Prelude
import Gargantext.API.Settings
import Gargantext.API.Ngrams
import Gargantext.Database.Tree
......@@ -24,18 +37,75 @@ import Gargantext.Core.Types
import Gargantext.Database.Utils
import Gargantext.Database.Schema.Node
class HasServerError e where
_ServerError :: Prism' e ServerError
type GargServer api =
forall env err m.
serverError :: (MonadError e m, HasServerError e) => ServerError -> m a
serverError e = throwError $ _ServerError # e
class HasJoseError e where
_JoseError :: Prism' e Jose.Error
joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
joseError = throwError . (_JoseError #)
class ThrowAll' e a | a -> e where
-- | 'throwAll' is a convenience function to throw errors across an entire
-- sub-API
--
--
-- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
-- > == throwError err400 :<|> throwError err400 :<|> err400
throwAll' :: e -> a
instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
throwAll' e = throwAll' e :<|> throwAll' e
-- Really this shouldn't be necessary - ((->) a) should be an instance of
-- MonadError, no?
instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
throwAll' e = const $ throwAll' e
instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
throwAll' = throwError
type GargServerC env err m =
( CmdM env err m
, HasNodeError err
, HasInvalidError err
, HasTreeError err
, HasServerError err
, HasJoseError err
, HasRepo env
, HasSettings env
)
=> ServerT api m
type GargServerT env err m api = GargServerC env err m => ServerT api m
type GargServer api =
forall env err m. GargServerT env err m api
data GargError
= GargNodeError NodeError
| GargTreeError TreeError
| GargInvalidError Validation
| GargJoseError Jose.Error
| GargServerError ServerError
deriving (Show)
makePrisms ''GargError
instance HasNodeError GargError where
_NodeError = _GargNodeError
instance HasInvalidError GargError where
_InvalidError = _GargInvalidError
instance HasTreeError GargError where
_TreeError = _GargTreeError
instance HasServerError GargError where
_ServerError = _GargServerError
instance HasJoseError GargError where
_JoseError = _GargJoseError
......@@ -17,9 +17,9 @@ Gargantext's database.
{-# LANGUAGE NoImplicitPrelude #-}
module Gargantext.Database ( module Gargantext.Database.Utils
, module Gargantext.Database.Bashql
-- , module Gargantext.Database.Bashql
)
where
import Gargantext.Database.Utils (connectGargandb)
import Gargantext.Database.Bashql
-- import Gargantext.Database.Bashql
......@@ -7,6 +7,7 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
TODO-SECURITY review purpose of this module
-}
{-# LANGUAGE NoImplicitPrelude #-}
......
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-|
Module : Gargantext.Database.Bashql
Description : BASHQL to deal with Gargantext Database.
......@@ -55,13 +56,15 @@ AMS, and by SIAM.
[3] https://github.com/Gabriel439/Haskell-Turtle-Library
TODO-ACCESS: should the checks be done here or before.
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Bashql ( get
module Gargantext.Database.Bashql () {-( get
, ls
, home
, post
......@@ -71,7 +74,7 @@ module Gargantext.Database.Bashql ( get
, rename
, tree
-- , mkCorpus, mkAnnuaire
)
)-}
where
import Control.Monad.Reader -- (Reader, ask)
......
......@@ -26,10 +26,22 @@ Portability : POSIX
{-# LANGUAGE TypeFamilies #-}
------------------------------------------------------------------------
module Gargantext.Database.Facet
( runViewAuthorsDoc
, runViewDocuments
, filterWith
, Pair(..)
, Facet(..)
, FacetDoc
, FacetDocRead
, FacetPaired(..)
, FacetPairedRead
, OrderBy(..)
)
where
------------------------------------------------------------------------
import Control.Arrow (returnA)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
-- import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.TH (deriveJSON)
import Data.Either(Either(Left))
......@@ -70,9 +82,9 @@ type Title = Text
-- TODO remove Title
type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Favorite) (Maybe Double)
type FacetSources = FacetDoc
type FacetAuthors = FacetDoc
type FacetTerms = FacetDoc
-- type FacetSources = FacetDoc
-- type FacetAuthors = FacetDoc
-- type FacetTerms = FacetDoc
data Facet id created title hyperdata favorite ngramCount =
......@@ -158,7 +170,7 @@ instance Arbitrary FacetDoc where
-- Facets / Views for the Front End
-- | Database instances
$(makeAdaptorAndInstance "pFacetDoc" ''Facet)
$(makeLensesWith abbreviatedFields ''Facet)
-- $(makeLensesWith abbreviatedFields ''Facet)
type FacetDocRead = Facet (Column PGInt4 )
(Column PGTimestamptz)
......@@ -196,6 +208,7 @@ instance Arbitrary OrderBy
arbitrary = elements [minBound..maxBound]
-- TODO-SECURITY check
runViewAuthorsDoc :: ContactId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
where
......@@ -236,6 +249,7 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
------------------------------------------------------------------------
-- TODO-SECURITY check
runViewDocuments :: CorpusId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
runViewDocuments cId t o l order =
runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
......
......@@ -31,6 +31,13 @@ Portability : POSIX
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
( FlowCmdM
, flowCorpusFile
, flowCorpus
, flowCorpusSearchInDatabase
, getOrMkRoot
, getOrMkRootWithCorpus
)
where
import Prelude (String)
import Data.Either
......@@ -45,7 +52,7 @@ import Data.Monoid
import Data.Text (Text, splitOn, intercalate)
import GHC.Show (Show)
import Gargantext.API.Ngrams (HasRepoVar)
import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams, RepoCmdM)
import Gargantext.API.Ngrams (NgramsElement, putListNgrams, RepoCmdM)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types (NodePoly(..), Terms(..))
import Gargantext.Core.Types.Individu (Username)
......@@ -99,30 +106,32 @@ getDataApi lang limit (ApiIsidoreQuery q) = Isidore.get lang limit (Just q) Noth
getDataApi lang limit (ApiIsidoreAuth q) = Isidore.get lang limit Nothing (Just q)
flowCorpusApi :: ( FlowCmdM env err m)
-- UNUSED
_flowCorpusApi :: ( FlowCmdM env err m)
=> Username -> Either CorpusName [CorpusId]
-> TermType Lang
-> Maybe Limit
-> ApiQuery
-> m CorpusId
flowCorpusApi u n tt l q = do
_flowCorpusApi u n tt l q = do
docs <- liftIO $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
flowCorpus u n tt docs
------------------------------------------------------------------------
flowAnnuaire :: FlowCmdM env err m
-- UNUSED
_flowAnnuaire :: FlowCmdM env err m
=> Username -> Either CorpusName [CorpusId] -> (TermType Lang) -> FilePath -> m AnnuaireId
flowAnnuaire u n l filePath = do
_flowAnnuaire u n l filePath = do
docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
flowCorpusDebat :: FlowCmdM env err m
-- UNUSED
_flowCorpusDebat :: FlowCmdM env err m
=> Username -> Either CorpusName [CorpusId]
-> Limit -> FilePath
-> m CorpusId
flowCorpusDebat u n l fp = do
_flowCorpusDebat u n l fp = do
docs <- liftIO ( splitEvery 500
<$> take l
<$> readFile' fp
......@@ -151,19 +160,22 @@ flowCorpusSearchInDatabase u la q = do
flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
flowCorpusSearchInDatabaseApi :: FlowCmdM env err m
-- UNUSED
_flowCorpusSearchInDatabaseApi :: FlowCmdM env err m
=> Username -> Lang -> Text -> m CorpusId
flowCorpusSearchInDatabaseApi u la q = do
_flowCorpusSearchInDatabaseApi u la q = do
(_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster (Left "") (Nothing :: Maybe HyperdataCorpus)
ids <- map fst <$> searchInDatabase cId (stemIt q)
flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
------------------------------------------------------------------------
-- | TODO improve the needed type to create/update a corpus
{- UNUSED
data UserInfo = Username Text
| UserId NodeId
data CorpusInfo = CorpusName Lang Text
| CorpusId Lang NodeId
-}
flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)
......
......@@ -16,6 +16,7 @@ Portability : POSIX
-- {-# LANGUAGE Arrows #-}
module Gargantext.Database.Flow.Pairing
(pairing)
where
--import Debug.Trace (trace)
......
......@@ -41,6 +41,7 @@ data Update = Rename NodeId Name
unOnly :: Only a -> a
unOnly (Only a) = a
-- TODO-ACCESS
update :: Update -> Cmd err [Int]
update (Rename nId name) = map unOnly <$> runPGSQuery "UPDATE nodes SET name=? where id=? returning id"
(DT.take 255 name,nId)
......
......@@ -82,6 +82,7 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
type AuthorName = Text
-- | TODO Optim: Offset and Limit in the Query
-- TODO-SECURITY check
searchInCorpusWithContacts :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
<$> map (\((i,u,h,s), ps) -> FacetPaired i u h s (catMaybes ps))
......@@ -94,6 +95,7 @@ searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop
maybePair (Pair Nothing _) = Nothing
maybePair (Pair (Just p_id) (Just p_label)) = Just $ Pair p_id p_label
-- TODO-SECURITY check
searchInCorpusWithContacts' :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
searchInCorpusWithContacts' cId q o l order = runOpaQuery $ queryInCorpusWithContacts cId q' o l order
where
......
......@@ -41,9 +41,8 @@ import Data.ByteString.Lazy (ByteString)
import Data.Either
import Data.Eq (Eq)
import Data.Monoid (mempty)
import Data.Text (Text, unpack, pack)
import Data.Text (Text, unpack)
import Data.Time (UTCTime)
import Data.Time.Segment (jour, timesAfter, Granularity(D))
import Data.Swagger
import Text.Read (read)
......@@ -55,6 +54,8 @@ import Servant
import Test.QuickCheck.Arbitrary
import Test.QuickCheck (elements)
import Test.QuickCheck.Instances.Time ()
import Test.QuickCheck.Instances.Text ()
import Gargantext.Prelude
import Gargantext.Core.Utils.Prefix (unPrefix)
......@@ -133,12 +134,6 @@ type MasterUserId = UserId
id2int :: NodeId -> Int
id2int (NodeId n) = n
type UTCTime' = UTCTime
instance Arbitrary UTCTime' where
arbitrary = elements $ timesAfter 100 D (jour 2000 01 01)
------------------------------------------------------------------------
data Status = Status { status_failed :: !Int
, status_succeeded :: !Int
......@@ -276,15 +271,13 @@ instance ToSchema Event where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
------------------------------------------------------------------------
instance Arbitrary Text where
arbitrary = elements $ map (\c -> pack [c]) ['a'..'z']
data Resource = Resource { resource_path :: !(Maybe Text)
, resource_scraper :: !(Maybe Text)
, resource_query :: !(Maybe Text)
, resource_events :: !([Event])
, resource_status :: !Status
, resource_date :: !UTCTime'
, resource_date :: !UTCTime
} deriving (Show, Generic)
$(deriveJSON (unPrefix "resource_") ''Resource)
......
......@@ -6,7 +6,7 @@ packages:
docker:
enable: false
repo: 'cgenie/stack-build:lts-12.26'
repo: 'fpco/stack-build:lts-14.6-garg'
allow-newer: true
extra-deps:
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment