Secure API with JWT auth. Part 1

bin/gargantext-import/Main.hs

@@ -30,7 +30,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument)
 import Gargantext.Database.Schema.User (insertUsersDemo)
 import Gargantext.Text.Terms (TermType(..))
 import Gargantext.Core (Lang(..))
-import Gargantext.API -- (GargError)
+import Gargantext.API.Types (GargError)
 import Gargantext.API.Node () -- instances
 import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
 import System.Environment (getArgs)

bin/gargantext-init/Main.hs

@@ -28,7 +28,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument, RootId)
 import Gargantext.Database.Schema.User (insertUsersDemo, UserId)
 import Gargantext.Text.Terms (TermType(..))
 import Gargantext.Core (Lang(..))
-import Gargantext.API -- (GargError)
+import Gargantext.API.Types (GargError)
 import Gargantext.API.Node () -- instances
 import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
 --import Gargantext.Text.Corpus.Parsers.GrandDebat (readFile, GrandDebatReference(..))

devops/docker/Dockerfile

-from fpco/stack-build:lts-12.26
+from fpco/stack-build:lts-14.6
 
 RUN apt-get update && \
     apt-get install -y git libigraph0-dev && \

devops/docker/docker-postgres

@@ -4,6 +4,6 @@ docker rm --volumes dbgarg || :
 export PGPASSWORD="$(grep DB_PASS gargantext.ini | \awk '{print $3}')"
 docker run --name dbgarg -e POSTGRES_USER=gargantua -e POSTGRES_DB=gargandbV5 -e POSTGRES_PASSWORD=${PGPASSWORD} -d postgres
 sleep 3
-docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres  -U gargantua -d gargandbV5 < src/Gargantext/Database/Schema/schema.sql
+docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres  -U gargantua -d gargandbV5 < devops/postgres/schema.sql
 #docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres  -U gargantua  -d gargandbV5 < gargantext.dump
 #docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres dropdb -h postgres  -U gargantua gargandbV5

package.yaml

@@ -33,6 +33,7 @@ library:
     #  - Gargantext.API.Orchestrator
   - Gargantext.API.Search
   - Gargantext.API.Settings
+  - Gargantext.API.Types
   - Gargantext.Core
   - Gargantext.Core.Types
   - Gargantext.Core.Types.Main
@@ -130,7 +131,7 @@ library:
   - hlcm
   - ini
   - insert-ordered-containers
-  - jose-jwt
+  - jose
     #  - kmeans-vector
   - json-stream
   - KMP
@@ -160,6 +161,7 @@ library:
   - simple-reflect
   - cereal     # (IGraph)
   - singletons # (IGraph)
+  - quickcheck-instances
   - random
   - rake
   - regex-compat
@@ -169,6 +171,8 @@ library:
   - semigroups
   - servant
   - servant-auth
+  - servant-auth-server >= 0.4.4.0
+  - servant-auth-swagger
   - servant-blaze
   - servant-client
     #  - servant-job

src/Gargantext/API.hs

@@ -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)

src/Gargantext/API/Auth.hs

@@ -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"]

src/Gargantext/API/Corpus/New.hs

@@ -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

src/Gargantext/API/Ngrams.hs

+{-# 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

src/Gargantext/API/Ngrams/Tools.hs

@@ -33,6 +33,10 @@ import qualified Data.Set as Set
 
 type RootTerm = Text
 
+-- TODO-ACCESS: We want to do the security check before entering here.
+--              Add a static capability parameter would be nice.
+--              Ideally this is the access to `repoVar` which needs to
+--              be properly guarded.
 getListNgrams :: RepoCmdM env err m
                => [ListId] -> NgramsType
                -> m (Map Text NgramsRepoElement)

src/Gargantext/API/Node.hs

@@ -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

src/Gargantext/API/Settings.hs

@@ -6,6 +6,8 @@ License     : AGPL + CECILL v3
 Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
+
+TODO-SECURITY: Critical
 -}
 
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -40,16 +42,15 @@ import Data.Aeson
 import Data.Maybe (fromMaybe)
 import Data.Either (either)
 import Data.Text
-import Data.Text.Encoding (encodeUtf8)
+--import Data.Text.Encoding (encodeUtf8)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as L
 
 import Servant
+import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings, defaultCookieSettings, readKey, writeKey)
 import Servant.Client (BaseUrl, parseBaseUrl)
 --import Servant.Job.Async (newJobEnv, defaultSettings)
 import Web.HttpApiData (parseUrlPiece)
-import qualified Jose.Jwk as Jose
-import qualified Jose.Jwa as Jose
 
 import Control.Concurrent
 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
@@ -77,7 +78,8 @@ data Settings = Settings
     , _logLevelLimit   :: LogLevel -- log level from the monad-logger package
 --    , _dbServer        :: Text
 --    ^ this is not used yet
-    , _jwtSecret       :: Jose.Jwk -- key from the jose-jwt package
+    , _jwtSettings     :: JWTSettings
+    , _cookieSettings  :: CookieSettings
     , _sendLoginEmails :: SendEmailType
     , _scrapydUrl      :: BaseUrl
     , _fileFolder      :: FilePath
@@ -89,29 +91,22 @@ class HasSettings env where
   settings :: Getter env Settings
 
 
-parseJwk :: Text -> Jose.Jwk
-parseJwk secretStr = jwk
-    where
-        secretBs = encodeUtf8 secretStr
-        jwk      = Jose.SymmetricJwk secretBs 
-                                     Nothing 
-                                     Nothing 
-                                     (Just $ Jose.Signed Jose.HS256)
-
-devSettings :: Settings
-devSettings = Settings
+devSettings :: FilePath -> IO Settings
+devSettings jwkFile = do
+  jwkExists <- doesFileExist jwkFile
+  when (not jwkExists) $ writeKey jwkFile
+  jwk <- readKey jwkFile
+  pure $ Settings
     { _allowedOrigin = "http://localhost:8008"
     , _allowedHost = "localhost:3000"
     , _appPort = 3000
     , _logLevelLimit = LevelDebug
 --    , _dbServer = "localhost"
-    -- generate with dd if=/dev/urandom bs=1 count=32 | base64
-    -- make sure jwtSecret differs between development and production, because you do not want
-    -- your production key inside source control.
-    , _jwtSecret = parseJwk "MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
     , _sendLoginEmails = LogEmailToConsole
     , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
     , _fileFolder = "data"
+    , _cookieSettings = defaultCookieSettings -- TODO-SECURITY tune
+    , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
     }
 
 
@@ -232,10 +227,13 @@ readRepoEnv = do
   saver <- mkRepoSaver mvar
   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 
+devJwkFile :: FilePath
+devJwkFile = "dev.jwk"
+
 newEnv :: PortNumber -> FilePath -> IO Env
 newEnv port file = do
   manager <- newTlsManager
-  settings <- pure (devSettings & appPort .~ port) -- TODO read from 'file'
+  settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
   when (port /= settings ^. appPort) $
     panic "TODO: conflicting settings of port"
 
@@ -295,10 +293,11 @@ withDevEnv iniPath k = do
       param <- databaseParameters iniPath
       conn  <- connect param
       repo  <- readRepoEnv
+      setts <- devSettings devJwkFile
       pure $ DevEnv
         { _dev_env_conn = conn
         , _dev_env_repo = repo
-        , _dev_env_settings = devSettings
+        , _dev_env_settings = setts
         }
 
 -- | Run Cmd Sugar for the Repl (GHCI)

src/Gargantext/API/Types.hs

@@ -10,13 +10,26 @@ Portability : POSIX
 -}
 
 
-{-# LANGUAGE NoImplicitPrelude  #-}
-{-# LANGUAGE RankNTypes         #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE NoImplicitPrelude      #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
 
 module Gargantext.API.Types
   where
 
+import Control.Lens (Prism', (#))
+import Control.Lens.TH (makePrisms)
+import Control.Monad.Error.Class (MonadError(throwError))
+import Crypto.JOSE.Error as Jose
+import Data.Validity
 import Servant
+import Gargantext.Prelude
 import Gargantext.API.Settings
 import Gargantext.API.Ngrams
 import Gargantext.Database.Tree
@@ -24,18 +37,75 @@ import Gargantext.Core.Types
 import Gargantext.Database.Utils
 import Gargantext.Database.Schema.Node
 
+class HasServerError e where
+  _ServerError :: Prism' e ServerError
 
-type GargServer api =
-  forall env err m.
+serverError :: (MonadError e m, HasServerError e) => ServerError -> m a
+serverError e = throwError $ _ServerError # e
+
+class HasJoseError e where
+  _JoseError :: Prism' e Jose.Error
+
+joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
+joseError = throwError . (_JoseError #)
+
+class ThrowAll' e a | a -> e where
+  -- | 'throwAll' is a convenience function to throw errors across an entire
+  -- sub-API
+  --
+  --
+  -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
+  -- >    == throwError err400 :<|> throwError err400 :<|> err400
+  throwAll' :: e -> a
+
+instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
+  throwAll' e = throwAll' e :<|> throwAll' e
+
+-- Really this shouldn't be necessary - ((->) a) should be an instance of
+-- MonadError, no?
+instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
+  throwAll' e = const $ throwAll' e
+
+instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
+  throwAll' = throwError
+
+type GargServerC env err m =
     ( CmdM env err m
     , HasNodeError err
     , HasInvalidError err
     , HasTreeError err
+    , HasServerError err
+    , HasJoseError err
     , HasRepo env
     , HasSettings env
     )
-    => ServerT api m
 
+type GargServerT env err m api = GargServerC env err m => ServerT api m
+
+type GargServer api =
+  forall env err m. GargServerT env err m api
+
+data GargError
+  = GargNodeError NodeError
+  | GargTreeError TreeError
+  | GargInvalidError Validation
+  | GargJoseError Jose.Error
+  | GargServerError ServerError
+  deriving (Show)
+
+makePrisms ''GargError
+
+instance HasNodeError GargError where
+  _NodeError = _GargNodeError
+
+instance HasInvalidError GargError where
+  _InvalidError = _GargInvalidError
 
+instance HasTreeError GargError where
+  _TreeError = _GargTreeError
 
+instance HasServerError GargError where
+  _ServerError = _GargServerError
 
+instance HasJoseError GargError where
+  _JoseError = _GargJoseError

src/Gargantext/Database.hs

@@ -17,9 +17,9 @@ Gargantext's database.
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Gargantext.Database ( module Gargantext.Database.Utils
-                           , module Gargantext.Database.Bashql
+                        -- , module Gargantext.Database.Bashql
                            )
     where
 
 import Gargantext.Database.Utils (connectGargandb)
-import Gargantext.Database.Bashql
+-- import Gargantext.Database.Bashql

src/Gargantext/Database/Access.hs

@@ -7,6 +7,7 @@ Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
 
+TODO-SECURITY review purpose of this module
 -}
 
 {-# LANGUAGE NoImplicitPrelude #-}

src/Gargantext/Database/Bashql.hs

+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 {-|
 Module      : Gargantext.Database.Bashql
 Description : BASHQL to deal with Gargantext Database.
@@ -55,13 +56,15 @@ AMS, and by SIAM.
 
 [3] https://github.com/Gabriel439/Haskell-Turtle-Library
 
+TODO-ACCESS: should the checks be done here or before.
+
 -}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE RankNTypes        #-}
 
-module Gargantext.Database.Bashql ( get
+module Gargantext.Database.Bashql () {-( get
                                   , ls
                                   , home
                                   , post
@@ -71,7 +74,7 @@ module Gargantext.Database.Bashql ( get
                                   , rename
                                   , tree
                                   -- , mkCorpus, mkAnnuaire
-                                 )
+                                 )-}
     where
 
 import Control.Monad.Reader -- (Reader, ask)

src/Gargantext/Database/Facet.hs

@@ -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

src/Gargantext/Database/Flow.hs

@@ -31,6 +31,13 @@ Portability : POSIX
 {-# LANGUAGE OverloadedStrings       #-}
 
 module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
+  ( FlowCmdM
+  , flowCorpusFile
+  , flowCorpus
+  , flowCorpusSearchInDatabase
+  , getOrMkRoot
+  , getOrMkRootWithCorpus
+  )
     where
 import Prelude (String)
 import Data.Either
@@ -45,7 +52,7 @@ import Data.Monoid
 import Data.Text (Text, splitOn, intercalate)
 import GHC.Show (Show)
 import Gargantext.API.Ngrams (HasRepoVar)
-import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams, RepoCmdM)
+import Gargantext.API.Ngrams (NgramsElement, putListNgrams, RepoCmdM)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Types (NodePoly(..), Terms(..))
 import Gargantext.Core.Types.Individu (Username)
@@ -99,30 +106,32 @@ getDataApi lang limit (ApiIsidoreQuery q) = Isidore.get lang limit (Just q) Noth
 getDataApi lang limit (ApiIsidoreAuth  q) = Isidore.get lang limit Nothing  (Just q)
 
 
-flowCorpusApi :: ( FlowCmdM env err m)
+-- UNUSED
+_flowCorpusApi :: ( FlowCmdM env err m)
            => Username -> Either CorpusName [CorpusId]
            -> TermType Lang
            -> Maybe Limit
            -> ApiQuery
            -> m CorpusId
-flowCorpusApi u n tt l q = do
+_flowCorpusApi u n tt l q = do
   docs <- liftIO $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
   flowCorpus u n tt docs
 
 ------------------------------------------------------------------------
 
-flowAnnuaire :: FlowCmdM env err m
+-- UNUSED
+_flowAnnuaire :: FlowCmdM env err m
              => Username -> Either CorpusName [CorpusId] -> (TermType Lang) -> FilePath -> m AnnuaireId
-flowAnnuaire u n l filePath = do
+_flowAnnuaire u n l filePath = do
   docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
   flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
 
-
-flowCorpusDebat :: FlowCmdM env err m
+-- UNUSED
+_flowCorpusDebat :: FlowCmdM env err m
             => Username -> Either CorpusName [CorpusId]
             -> Limit -> FilePath
             -> m CorpusId
-flowCorpusDebat u n l fp = do
+_flowCorpusDebat u n l fp = do
   docs <- liftIO ( splitEvery 500
                  <$> take l
                  <$> readFile' fp
@@ -151,19 +160,22 @@ flowCorpusSearchInDatabase u la q = do
   flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
 
 
-flowCorpusSearchInDatabaseApi :: FlowCmdM env err m
+-- UNUSED
+_flowCorpusSearchInDatabaseApi :: FlowCmdM env err m
           => Username -> Lang -> Text -> m CorpusId
-flowCorpusSearchInDatabaseApi u la q = do
+_flowCorpusSearchInDatabaseApi u la q = do
   (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster (Left "") (Nothing :: Maybe HyperdataCorpus)
   ids <-  map fst <$> searchInDatabase cId (stemIt q)
   flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
 
 ------------------------------------------------------------------------
 -- | TODO improve the needed type to create/update a corpus
+{- UNUSED
 data UserInfo = Username Text
               | UserId   NodeId
 data CorpusInfo = CorpusName Lang Text
                 | CorpusId   Lang NodeId
+-}
 
 
 flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)

src/Gargantext/Database/Flow/Pairing.hs

@@ -16,6 +16,7 @@ Portability : POSIX
 -- {-# LANGUAGE Arrows #-}
 
 module Gargantext.Database.Flow.Pairing
+  (pairing)
     where
 
 --import Debug.Trace (trace)

src/Gargantext/Database/Node/Update.hs

@@ -41,6 +41,7 @@ data Update = Rename NodeId Name
 unOnly :: Only a -> a
 unOnly (Only a) = a
 
+-- TODO-ACCESS
 update :: Update -> Cmd err [Int]
 update (Rename nId name) = map unOnly <$> runPGSQuery "UPDATE nodes SET name=? where id=? returning id"
                                            (DT.take 255 name,nId)

src/Gargantext/Database/TextSearch.hs

@@ -82,6 +82,7 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
 type AuthorName = Text
 
 -- | TODO Optim: Offset and Limit in the Query
+-- TODO-SECURITY check
 searchInCorpusWithContacts :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
 searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
   <$> map (\((i,u,h,s), ps) -> FacetPaired i u h s (catMaybes ps))
@@ -94,6 +95,7 @@ searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop
     maybePair (Pair Nothing _) = Nothing
     maybePair (Pair (Just p_id) (Just p_label)) = Just $ Pair p_id p_label
 
+-- TODO-SECURITY check
 searchInCorpusWithContacts' :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
 searchInCorpusWithContacts' cId q o l order = runOpaQuery $ queryInCorpusWithContacts cId q' o l order
   where

src/Gargantext/Database/Types/Node.hs

@@ -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)
 

stack.yaml

@@ -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: