{-|
Module      : Gargantext.API.Prelude
Description : Server API main Types
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MonoLocalBinds  #-}

module Gargantext.API.Prelude
  ( module Gargantext.API.Prelude
  , HasServerError(..)
  , serverError
  )
  where

import Control.Concurrent (threadDelay)
import Control.Exception (Exception)
import Control.Lens (Prism', (#))
import Control.Lens.TH (makePrisms)
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 Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Mail.Types (HasMail)
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
import Servant.Job.Core (HasServerError(..), serverError)

class HasJoseError e where
  _JoseError :: Prism' e Jose.Error

joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
joseError :: Error -> m a
joseError = e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m a) -> (Error -> e) -> Error -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tagged Error (Identity Error) -> Tagged e (Identity e)
forall e. HasJoseError e => Prism' e Error
_JoseError (Tagged Error (Identity Error) -> Tagged e (Identity e))
-> Error -> e
forall t b. AReview t b -> b -> t
#)

type HasJobEnv' env = HasJobEnv env JobLog JobLog

type EnvC env =
  ( HasConnectionPool env
  , HasSettings       env  -- TODO rename HasDbSettings
  , HasJobEnv         env JobLog JobLog
  , HasConfig         env
  , HasNodeStoryEnv   env
  , HasMail           env
  )

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 =
  ( CmdRandom env err m
  , HasNodeStory env err m
  , EnvC  env
  , ErrC      err
  , MimeRender JSON 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.
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
  , HasNodeStory   env err m
  , HasSettings    env
  , HasNodeError       err
  )

-------------------------------------------------------------------

data GargError
  = GargNodeError    NodeError
  | GargTreeError    TreeError
  | GargInvalidError Validation
  | GargJoseError    Jose.Error
  | GargServerError  ServerError
  deriving (Int -> GargError -> ShowS
[GargError] -> ShowS
GargError -> String
(Int -> GargError -> ShowS)
-> (GargError -> String)
-> ([GargError] -> ShowS)
-> Show GargError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GargError] -> ShowS
$cshowList :: [GargError] -> ShowS
show :: GargError -> String
$cshow :: GargError -> String
showsPrec :: Int -> GargError -> ShowS
$cshowsPrec :: Int -> GargError -> ShowS
Show, Typeable)

makePrisms ''GargError

instance ToJSON GargError where
  toJSON :: GargError -> Value
toJSON GargError
_ = Text -> Value
String Text
"SomeGargErrorPleaseReport"

instance Exception GargError

instance HasNodeError GargError where
  _NodeError :: p NodeError (f NodeError) -> p GargError (f GargError)
_NodeError = p NodeError (f NodeError) -> p GargError (f GargError)
Prism' GargError NodeError
_GargNodeError

instance HasInvalidError GargError where
  _InvalidError :: p Validation (f Validation) -> p GargError (f GargError)
_InvalidError = p Validation (f Validation) -> p GargError (f GargError)
Prism' GargError Validation
_GargInvalidError

instance HasTreeError GargError where
  _TreeError :: p TreeError (f TreeError) -> p GargError (f GargError)
_TreeError = p TreeError (f TreeError) -> p GargError (f GargError)
Prism' GargError TreeError
_GargTreeError

instance HasServerError GargError where
  _ServerError :: p ServerError (f ServerError) -> p GargError (f GargError)
_ServerError = p ServerError (f ServerError) -> p GargError (f GargError)
Prism' GargError ServerError
_GargServerError

instance HasJoseError GargError where
  _JoseError :: p Error (f Error) -> p GargError (f GargError)
_JoseError = p Error (f Error) -> p GargError (f GargError)
Prism' GargError Error
_GargJoseError


------------------------------------------------------------------------
-- | Utils
-- | Simulate logs
simuLogs  :: MonadBase IO m
         => (JobLog -> m ())
         -> Int
         -> m JobLog
simuLogs :: (JobLog -> m ()) -> Int -> m JobLog
simuLogs JobLog -> m ()
logStatus Int
t = do
  [()]
_ <- (Int -> m ()) -> [Int] -> m [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
n -> (JobLog -> m ()) -> Int -> Int -> m ()
forall (m :: * -> *).
MonadBase IO m =>
(JobLog -> m ()) -> Int -> Int -> m ()
simuTask JobLog -> m ()
logStatus Int
n Int
t) ([Int] -> m [()]) -> [Int] -> m [()]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
t [Int
0,Int
1..]
  JobLog -> m JobLog
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JobLog -> m JobLog) -> JobLog -> m JobLog
forall a b. (a -> b) -> a -> b
$ JobLog :: Maybe Int
-> Maybe Int -> Maybe Int -> Maybe [ScraperEvent] -> JobLog
JobLog { _scst_succeeded :: Maybe Int
_scst_succeeded = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
t
                , _scst_failed :: Maybe Int
_scst_failed    = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
                , _scst_remaining :: Maybe Int
_scst_remaining = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
                , _scst_events :: Maybe [ScraperEvent]
_scst_events    = [ScraperEvent] -> Maybe [ScraperEvent]
forall a. a -> Maybe a
Just []
                }

simuTask :: MonadBase IO m
          => (JobLog -> m ())
          -> Int
          -> Int
          -> m ()
simuTask :: (JobLog -> m ()) -> Int -> Int -> m ()
simuTask JobLog -> m ()
logStatus Int
cur Int
total = do
  let m :: Int
m = (Int
10 :: Int) Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
6 :: Int)
  IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
5)

  let status :: JobLog
status =  JobLog :: Maybe Int
-> Maybe Int -> Maybe Int -> Maybe [ScraperEvent] -> JobLog
JobLog { _scst_succeeded :: Maybe Int
_scst_succeeded = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
cur
                       , _scst_failed :: Maybe Int
_scst_failed    = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
                       , _scst_remaining :: Maybe Int
_scst_remaining = (-) (Int -> Int -> Int) -> Maybe Int -> Maybe (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
total Maybe (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
cur
                       , _scst_events :: Maybe [ScraperEvent]
_scst_events    = [ScraperEvent] -> Maybe [ScraperEvent]
forall a. a -> Maybe a
Just []
                       }
  String -> JobLog -> m ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
String -> a -> m ()
printDebug String
"status" JobLog
status
  JobLog -> m ()
logStatus JobLog
status