Split the API module and re-org

src/Gargantext/API.hs

@@ -26,15 +26,7 @@ Pouillard (who mainly made it).
 
 -}
 
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-
-{-# LANGUAGE ConstraintKinds      #-}
-{-# LANGUAGE TemplateHaskell      #-}
-{-# LANGUAGE TypeOperators        #-}
-{-# LANGUAGE KindSignatures       #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
-{-# LANGUAGE TypeFamilies         #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 ---------------------------------------------------------------------
 module Gargantext.API
@@ -42,42 +34,32 @@ module Gargantext.API
 ---------------------------------------------------------------------
 import Control.Exception (finally)
 import Control.Lens
-import Control.Monad.Except (withExceptT)
 import Control.Monad.Reader (runReaderT)
 import Data.List (lookup)
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Validity
-import Data.Version (showVersion)
 import GHC.Base (Applicative)
-import GHC.Generics (D1, Meta (..), Rep, Generic)
-import GHC.TypeLits (AppendSymbol, Symbol)
+import GHC.Generics (Generic)
 import Network.HTTP.Types hiding (Query)
 import Network.Wai
 import Network.Wai.Handler.Warp hiding (defaultSettings)
 import Network.Wai.Middleware.Cors
 import Network.Wai.Middleware.RequestLogger
 import Servant
-import Servant.Auth.Server (AuthResult(..))
-import Servant.Swagger.UI (swaggerSchemaUIServer)
 import System.IO (FilePath)
-import qualified Data.ByteString.Lazy.Char8 as BL8
-import qualified Data.Text.IO               as T
-import qualified Paths_gargantext           as PG -- cabal magic build module
-
-import qualified Gargantext.API.Public      as Public
+import Data.Text.IO (putStrLn)
 
 import Gargantext.Prelude.Config (gc_url_backend_api)
-import Gargantext.API.Admin.Auth (AuthContext, auth)
-import Gargantext.API.Admin.FrontEnd (frontEndServer)
+import Gargantext.API.Admin.Auth (AuthContext)
 import Gargantext.API.Admin.Settings (newEnv)
 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, env_gargConfig, jwtSettings, settings)
 import Gargantext.API.Ngrams (saveRepo)
 import Gargantext.API.Ngrams.Types (HasRepoSaver(..))
 import Gargantext.API.Prelude
 import Gargantext.API.Routes
-import Gargantext.API.Swagger (swaggerDoc)
-import Gargantext.Prelude
+import Gargantext.API.Server (server)
+import Gargantext.Prelude hiding (putStrLn)
 
 
 data Mode = Dev | Mock | Prod 
@@ -97,14 +79,14 @@ startGargantext mode port file = do
 
 portRouteInfo :: PortNumber -> IO ()
 portRouteInfo port = do
-  T.putStrLn "      ----Main Routes-----      "
-  T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
-  T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
+  putStrLn "      ----Main Routes-----      "
+  putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
+  putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 
 -- TODO clean this Monad condition (more generic) ?
 stopGargantext :: HasRepoSaver env => env -> IO ()
 stopGargantext env = do
-  T.putStrLn "----- Stopping gargantext -----"
+  putStrLn "----- Stopping gargantext -----"
   runReaderT saveRepo env
 
 {-
@@ -200,46 +182,9 @@ makeDevMiddleware mode = do
 ---------------------------------------------------------------------
 -- | API Global
 ---------------------------------------------------------------------
--- | Server declarations
-server :: forall env. EnvC env => env -> Text -> IO (Server API)
-server env baseUrl = do
-  -- orchestrator <- scrapyOrchestrator env
-  pure $  swaggerSchemaUIServer swaggerDoc
-     :<|> hoistServerWithContext
-            (Proxy :: Proxy GargAPI)
-            (Proxy :: Proxy AuthContext)
-            transform
-            (serverGargAPI baseUrl)
-     :<|> frontEndServer
-  where
-    transform :: forall a. GargServerM env GargError a -> Handler a
-    transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
-
-
-
-showAsServantErr :: GargError -> ServerError
-showAsServantErr (GargServerError err) = err
-showAsServantErr a = err500 { errBody = BL8.pack $ show a }
 
 ---------------------------
 
-serverGargAPI :: Text -> GargServerT env err (GargServerM env err) GargAPI
-serverGargAPI baseUrl -- orchestrator
-       =  auth
-     :<|> gargVersion
-     :<|> serverPrivateGargAPI
-     :<|> (Public.api baseUrl)
-
-  --   :<|> orchestrator
-  where
-    gargVersion :: GargServer GargVersion
-    gargVersion = pure (cs $ showVersion PG.version)
-
-    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?
@@ -272,6 +217,9 @@ apiGarg :: Proxy GargAPI
 apiGarg  = Proxy
 ---------------------------------------------------------------------
 
+{- UNUSED
+--import GHC.Generics (D1, Meta (..), Rep, Generic)
+--import GHC.TypeLits (AppendSymbol, Symbol)
 ---------------------------------------------------------------------
 -- Type Family for the Documentation
 type family TypeName (x :: *) :: Symbol where
@@ -283,5 +231,4 @@ type family GenericTypeName t (r :: *) :: Symbol where
     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 
 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
-
-
+-}
\ No newline at end of file

src/Gargantext/API/Node/Contact.hs

@@ -17,7 +17,6 @@ Portability : POSIX
 {-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 
 module Gargantext.API.Node.Contact

src/Gargantext/API/Prelude.hs

@@ -9,11 +9,8 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE ConstraintKinds        #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE TemplateHaskell        #-}
-{-# LANGUAGE TypeOperators          #-}
-{-# LANGUAGE UndecidableInstances   #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Gargantext.API.Prelude
   ( module Gargantext.API.Prelude
@@ -52,58 +49,39 @@ class HasJoseError e where
 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
+type EnvC env =
+  ( HasConnectionPool env
+  , HasRepo           env  -- TODO rename HasNgramsRepo
+  , HasSettings       env  -- TODO rename HasDbSettings
+  , HasJobEnv         env JobLog JobLog
+  , HasConfig         env
+  )
 
-instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
-  throwAll' = throwError
+type ErrC err =
+  ( HasNodeError     err
+  , HasInvalidError  err
+  , HasTreeError     err
+  , HasServerError   err
+  , HasJoseError     err
+  , ToJSON           err -- TODO this is arguable
+  , Exception        err
+  )
 
 type GargServerC env err m =
-    ( CmdM         env err m
-    , HasNodeError     err
-    , HasInvalidError  err
-    , HasTreeError     err
-    , HasServerError   err
-    , HasJoseError     err
-    , ToJSON           err -- TODO this is arguable
-    , Exception        err
-    , HasRepo      env  -- TODO rename HasNgramsRepo
-    , HasSettings  env  -- TODO rename HasDbSettings
-    , HasJobEnv    env JobLog JobLog
-    , HasConfig    env
-    )
-
-
-type GargServer api =
-  forall env err m. GargServerT env err m api
+  ( CmdM' env err m
+  , EnvC  env
+  , ErrC      err
+  )
 
 type GargServerT env err m api = GargServerC env err m => ServerT api m
 
--- 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)
+type GargServer api = forall env err m. GargServerT env err m api
 
-type EnvC env =
-  ( HasConnectionPool env
-  , HasRepo           env
-  , HasSettings       env
-  , HasJobEnv         env JobLog JobLog
-  , HasConfig         env
-  )
+-- This is the concrete monad. It needs to be used as little as possible.
+type GargM env err = ReaderT env (ExceptT err IO)
+-- This is the server type using GargM. It needs to be used as little as possible.
+-- Instead, prefer GargServer, GargServerT.
+type GargServerM env err api = (EnvC env, ErrC err) => ServerT api (GargM env err)
 
 -------------------------------------------------------------------
 -- | This Type is needed to prepare the function before the GargServer

src/Gargantext/API/Routes.hs

@@ -17,7 +17,6 @@ Portability : POSIX
 {-# LANGUAGE KindSignatures       #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 ---------------------------------------------------------------------
 module Gargantext.API.Routes

src/Gargantext/API/Server.hs

+{-|
+Module      : Gargantext.API.Server
+Description : REST API declaration
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# LANGUAGE ScopedTypeVariables  #-}
+
+---------------------------------------------------------------------
+module Gargantext.API.Server where
+---------------------------------------------------------------------
+import Control.Monad.Except (withExceptT)
+import Control.Monad.Reader (runReaderT)
+import Data.Text (Text)
+import Data.Version (showVersion)
+import Servant
+import Servant.Swagger.UI (swaggerSchemaUIServer)
+import qualified Data.ByteString.Lazy.Char8 as BL8
+import qualified Paths_gargantext           as PG -- cabal magic build module
+
+import qualified Gargantext.API.Public      as Public
+
+import Gargantext.API.Admin.Auth (AuthContext, auth)
+import Gargantext.API.Admin.FrontEnd (frontEndServer)
+import Gargantext.API.Prelude
+import Gargantext.API.Routes
+import Gargantext.API.Swagger (swaggerDoc)
+import Gargantext.API.ThrowAll (serverPrivateGargAPI)
+import Gargantext.Prelude
+
+
+serverGargAPI :: Text -> GargServerM env err GargAPI
+serverGargAPI baseUrl -- orchestrator
+       =  auth
+     :<|> gargVersion
+     :<|> serverPrivateGargAPI
+     :<|> Public.api baseUrl
+
+  --   :<|> orchestrator
+  where
+    gargVersion :: GargServer GargVersion
+    gargVersion = pure (cs $ showVersion PG.version)
+
+-- | Server declarations
+server :: forall env. EnvC env => env -> Text -> IO (Server API)
+server env baseUrl = do
+  -- orchestrator <- scrapyOrchestrator env
+  pure $  swaggerSchemaUIServer swaggerDoc
+     :<|> hoistServerWithContext
+            (Proxy :: Proxy GargAPI)
+            (Proxy :: Proxy AuthContext)
+            transform
+            (serverGargAPI baseUrl)
+     :<|> frontEndServer
+  where
+    transform :: forall a. GargM env GargError a -> Handler a
+    transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
+
+
+showAsServantErr :: GargError -> ServerError
+showAsServantErr (GargServerError err) = err
+showAsServantErr a = err500 { errBody = BL8.pack $ show a }
\ No newline at end of file

src/Gargantext/API/ThrowAll.hs

+{-|
+Module      : Gargantext.API.ThrowAll
+Description : ThrowAll class and instance
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+
+module Gargantext.API.ThrowAll where
+
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Lens ((#))
+import Servant
+import Servant.Auth.Server (AuthResult(..))
+import Gargantext.Prelude
+import Gargantext.API.Prelude (GargServerM, _ServerError)
+import Gargantext.API.Routes (GargPrivateAPI, serverPrivateGargAPI')
+
+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
+
+serverPrivateGargAPI :: GargServerM env err GargPrivateAPI
+serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
+serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
+-- Here throwAll' requires a concrete type for the monad.
\ No newline at end of file