[FIX] removing cLouvain c++ lib
[gargantext.git] / src / Gargantext / API / Prelude.hs
index bed787a9a554dedf5b6ec9a732c6e3fbaf9bbe44..722ddef4eb50fa27d2b824890892b9f499901bbd 100644 (file)
@@ -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
@@ -26,24 +23,25 @@ import Control.Concurrent (threadDelay)
 import Control.Exception (Exception)
 import Control.Lens (Prism', (#))
 import Control.Lens.TH (makePrisms)
-import Control.Monad.Error.Class (MonadError(throwError))
+import Control.Monad.Error.Class (MonadError(..))
 import Control.Monad.Except (ExceptT)
 import Control.Monad.Reader (ReaderT)
 import Crypto.JOSE.Error as Jose
 import Data.Aeson.Types
 import Data.Typeable
 import Data.Validity
+import Servant
+import Servant.Job.Async
+import Servant.Job.Core (HasServerError(..), serverError)
+
 import Gargantext.API.Admin.Orchestrator.Types
-import Gargantext.API.Admin.Settings
-import Gargantext.API.Ngrams
+import Gargantext.API.Admin.Types
+import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
 import Gargantext.Database.Query.Tree
 import Gargantext.Prelude
-import Servant
-import Servant.Job.Async (HasJobEnv)
-import Servant.Job.Core (HasServerError(..), serverError)
 
 class HasJoseError e where
   _JoseError :: Prism' e Jose.Error
@@ -51,62 +49,45 @@ 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
-    , HasSettings  env
-    , HasJobEnv    env ScraperStatus ScraperStatus
-    )
+  ( CmdRandom env err m
+  , EnvC  env
+  , ErrC      err
+  )
 
 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
-
--- 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 EnvC env =
-  ( HasConnectionPool env
-  , HasRepo env
-  , HasSettings env
-  , HasJobEnv env ScraperStatus ScraperStatus
-  )
+type GargServer api = forall env err m. GargServerT env err m api
 
--------------------------------------------------------------------
-runCmdReplEasy :: Cmd' DevEnv GargError a -> IO a
-runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
+-- 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
+type GargNoServer t =
+  forall env err m. GargNoServer' env err m => m t
+
 type GargNoServer' env err m =
   ( CmdM           env err m
   , HasRepo        env
@@ -114,8 +95,6 @@ type GargNoServer' env err m =
   , HasNodeError       err
   )
 
-type GargNoServer t =
-  forall env err m. GargNoServer' env err m => m t
 -------------------------------------------------------------------
 
 data GargError
@@ -152,40 +131,31 @@ instance HasJoseError GargError where
 ------------------------------------------------------------------------
 -- | Utils
 -- | Simulate logs
-
 simuLogs  :: MonadBase IO m
-         => (ScraperStatus -> m a)
+         => (JobLog -> m ())
          -> Int
-         -> m ScraperStatus
+         -> m JobLog
 simuLogs logStatus t = do
-  let task = ScraperStatus { _scst_succeeded = Just 0
-                           , _scst_failed    = Just 0
-                           , _scst_remaining = Just 0
-                           , _scst_events    = Just []
-                           }
-  f <- foldM' (\status n -> simuTask logStatus status n t) task $ take t [1..]
-  pure f
-
+  _ <- mapM (\n -> simuTask logStatus n t) $ take t [0,1..]
+  pure $ JobLog { _scst_succeeded = Just t
+                , _scst_failed    = Just 0
+                , _scst_remaining = Just 0
+                , _scst_events    = Just []
+                }
 
 simuTask :: MonadBase IO m
-         => (ScraperStatus -> m a)
-         -> ScraperStatus
-         -> Int
-         -> Int
-         -> m ScraperStatus
-simuTask logStatus (ScraperStatus s f _r e) n t = do
-  let
-    m = (10 :: Int) ^ (6 :: Int)
-  _ <- liftBase $ threadDelay ( m * 10)
-
-  let status =  ScraperStatus { _scst_succeeded = (+) <$> s <*> Just n
-                              , _scst_failed    = f
-                              , _scst_remaining = (-) <$> Just t <*> s
-                              , _scst_events    = e
-                              }
+          => (JobLog -> m ())
+          -> Int
+          -> Int
+          -> m ()
+simuTask logStatus cur total = do
+  let m = (10 :: Int) ^ (6 :: Int)
+  liftBase $ threadDelay (m*5)
+
+  let status =  JobLog { _scst_succeeded = Just cur
+                       , _scst_failed    = Just 0
+                       , _scst_remaining = (-) <$> Just total <*> Just cur
+                       , _scst_events    = Just []
+                       }
   printDebug "status" status
-  _ <- logStatus status
-  pure status
-
-
-
+  logStatus status