Generalize error type to make less use of ServantErr

parent 93400b1a
...@@ -21,7 +21,6 @@ module Main where ...@@ -21,7 +21,6 @@ module Main where
import Prelude (read) import Prelude (read)
import Control.Exception (finally) import Control.Exception (finally)
import Servant (ServantErr)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Database.Flow (FlowCmdM, flowCorpusFile) import Gargantext.Database.Flow (FlowCmdM, flowCorpusFile)
import Gargantext.Text.Corpus.Parsers (FileFormat(CsvHalFormat)) import Gargantext.Text.Corpus.Parsers (FileFormat(CsvHalFormat))
...@@ -30,6 +29,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument) ...@@ -30,6 +29,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument)
import Gargantext.Database.Schema.User (insertUsersDemo) import Gargantext.Database.Schema.User (insertUsersDemo)
import Gargantext.Text.Terms (TermType(..)) import Gargantext.Text.Terms (TermType(..))
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.API (GargError)
import Gargantext.API.Node () -- instances import Gargantext.API.Node () -- instances
import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv) import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
import System.Environment (getArgs) import System.Environment (getArgs)
...@@ -42,16 +42,16 @@ main = do ...@@ -42,16 +42,16 @@ main = do
[userCreate, user, name, iniPath, limit, corpusPath] <- getArgs [userCreate, user, name, iniPath, limit, corpusPath] <- getArgs
--{- --{-
let createUsers :: Cmd ServantErr Int64 let createUsers :: Cmd GargError Int64
createUsers = insertUsersDemo createUsers = insertUsersDemo
let let
--tt = (Unsupervised EN 5 1 Nothing) --tt = (Unsupervised EN 5 1 Nothing)
tt = (Mono EN) tt = (Mono EN)
cmd :: forall m. FlowCmdM DevEnv ServantErr m => m CorpusId cmd :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
cmd = flowCorpusFile (cs user) (cs name) (read limit :: Int) tt CsvHalFormat corpusPath cmd = flowCorpusFile (cs user) (cs name) (read limit :: Int) tt CsvHalFormat corpusPath
{- {-
let debatCorpus :: forall m. FlowCmdM DevEnv ServantErr m => m CorpusId let debatCorpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
debatCorpus = do debatCorpus = do
docs <- liftIO ( splitEvery 500 docs <- liftIO ( splitEvery 500
<$> take (read limit :: Int) <$> take (read limit :: Int)
......
...@@ -38,7 +38,7 @@ Node API ...@@ -38,7 +38,7 @@ Node API
module Gargantext.API.Node module Gargantext.API.Node
where where
import Control.Lens (prism', (.~), (?~)) import Control.Lens ((.~), (?~))
import Control.Monad ((>>), forM) import Control.Monad ((>>), forM)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, ToJSON) import Data.Aeson (FromJSON, ToJSON)
...@@ -58,9 +58,9 @@ import Gargantext.Core.Types.Main (Tree, NodeTree, ListType) ...@@ -58,9 +58,9 @@ import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
import Gargantext.Database.Config (nodeTypeId) import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),runViewAuthorsDoc) import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),runViewAuthorsDoc)
import Gargantext.Database.Node.Children (getChildren) import Gargantext.Database.Node.Children (getChildren)
import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, getNode', deleteNode, deleteNodes, mkNodeWithParent, JSONB, NodeError(..), HasNodeError(..)) import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, getNode', deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..))
import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash) import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..)) import Gargantext.Database.Tree (treeDB)
import Gargantext.Database.Types.Node import Gargantext.Database.Types.Node
import Gargantext.Database.Utils -- (Cmd, CmdM) import Gargantext.Database.Utils -- (Cmd, CmdM)
import Gargantext.Prelude import Gargantext.Prelude
...@@ -302,7 +302,9 @@ type TreeApi = Summary " Tree API" ...@@ -302,7 +302,9 @@ type TreeApi = Summary " Tree API"
------------------------------------------------------------------------ ------------------------------------------------------------------------
{-
NOTE: These instances are not necessary. However, these messages could be part
of a display function for NodeError/TreeError.
instance HasNodeError ServantErr where instance HasNodeError ServantErr where
_NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism") _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
where where
...@@ -320,7 +322,6 @@ instance HasNodeError ServantErr where ...@@ -320,7 +322,6 @@ instance HasNodeError ServantErr where
mk ManyParents = err500 { errBody = e <> "Too many parents" } mk ManyParents = err500 { errBody = e <> "Too many parents" }
mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user" } mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user" }
-- TODO(orphan): There should be a proper APIError data type with a case TreeError.
instance HasTreeError ServantErr where instance HasTreeError ServantErr where
_TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism") _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
where where
...@@ -328,6 +329,7 @@ instance HasTreeError ServantErr where ...@@ -328,6 +329,7 @@ instance HasTreeError ServantErr where
mk NoRoot = err404 { errBody = e <> "Root node not found" } mk NoRoot = err404 { errBody = e <> "Root node not found" }
mk EmptyRoot = err500 { errBody = e <> "Root node should not be empty" } mk EmptyRoot = err500 { errBody = e <> "Root node should not be empty" }
mk TooManyRoots = err500 { errBody = e <> "Too many root nodes" } mk TooManyRoots = err500 { errBody = e <> "Too many root nodes" }
-}
type TreeAPI = Get '[JSON] (Tree NodeTree) type TreeAPI = Get '[JSON] (Tree NodeTree)
-- TODO-ACCESS: CanTree or CanGetNode -- TODO-ACCESS: CanTree or CanGetNode
......
...@@ -66,7 +66,6 @@ import Gargantext.Text.Corpus.Parsers (parseFile, FileFormat) ...@@ -66,7 +66,6 @@ import Gargantext.Text.Corpus.Parsers (parseFile, FileFormat)
import qualified Gargantext.Text.Corpus.API.Isidore as Isidore import qualified Gargantext.Text.Corpus.API.Isidore as Isidore
import Gargantext.Text.Terms (TermType(..), tt_lang, extractTerms, uniText) import Gargantext.Text.Terms (TermType(..), tt_lang, extractTerms, uniText)
import Gargantext.Text.Terms.Mono.Stem.En (stemIt) import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
import Servant (ServantErr)
import System.FilePath (FilePath) import System.FilePath (FilePath)
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Map as Map
...@@ -101,7 +100,7 @@ getDataApi lang limit (ApiIsidoreQuery q) = Isidore.get lang limit (Just q) Noth ...@@ -101,7 +100,7 @@ getDataApi lang limit (ApiIsidoreQuery q) = Isidore.get lang limit (Just q) Noth
getDataApi lang limit (ApiIsidoreAuth q) = Isidore.get lang limit Nothing (Just q) getDataApi lang limit (ApiIsidoreAuth q) = Isidore.get lang limit Nothing (Just q)
flowCorpusApi :: ( FlowCmdM env ServantErr m) flowCorpusApi :: ( FlowCmdM env err m)
=> Username -> CorpusName => Username -> CorpusName
-> TermType Lang -> TermType Lang
-> Maybe Limit -> Maybe Limit
...@@ -114,14 +113,14 @@ flowCorpusApi u n tt l q = do ...@@ -114,14 +113,14 @@ flowCorpusApi u n tt l q = do
------------------------------------------------------------------------ ------------------------------------------------------------------------
flowAnnuaire :: FlowCmdM env ServantErr m flowAnnuaire :: FlowCmdM env err m
=> Username -> CorpusName -> (TermType Lang) -> FilePath -> m AnnuaireId => Username -> CorpusName -> (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]]) docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
flowCorpusDebat :: FlowCmdM env ServantErr m flowCorpusDebat :: FlowCmdM env err m
=> Username -> CorpusName => Username -> CorpusName
-> Limit -> FilePath -> Limit -> FilePath
-> m CorpusId -> m CorpusId
...@@ -133,7 +132,7 @@ flowCorpusDebat u n l fp = do ...@@ -133,7 +132,7 @@ flowCorpusDebat u n l fp = do
) )
flowCorpus u n (Multi FR) (map (map toHyperdataDocument) docs) flowCorpus u n (Multi FR) (map (map toHyperdataDocument) docs)
flowCorpusFile :: FlowCmdM env ServantErr m flowCorpusFile :: FlowCmdM env err m
=> Username -> CorpusName => Username -> CorpusName
-> Limit -- Limit the number of docs (for dev purpose) -> Limit -- Limit the number of docs (for dev purpose)
-> TermType Lang -> FileFormat -> FilePath -> TermType Lang -> FileFormat -> FilePath
...@@ -154,7 +153,7 @@ flowCorpusSearchInDatabase u la q = do ...@@ -154,7 +153,7 @@ flowCorpusSearchInDatabase u la q = do
flowCorpusUser la u q (Nothing :: Maybe HyperdataCorpus) ids flowCorpusUser la u q (Nothing :: Maybe HyperdataCorpus) ids
flowCorpusSearchInDatabase' :: FlowCmdM env ServantErr m flowCorpusSearchInDatabase' :: FlowCmdM env err m
=> Username -> Lang -> Text -> m CorpusId => Username -> Lang -> Text -> m CorpusId
flowCorpusSearchInDatabase' u la q = do flowCorpusSearchInDatabase' u la q = do
(_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster "" (Nothing :: Maybe HyperdataCorpus) (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster "" (Nothing :: Maybe HyperdataCorpus)
...@@ -163,13 +162,13 @@ flowCorpusSearchInDatabase' u la q = do ...@@ -163,13 +162,13 @@ flowCorpusSearchInDatabase' u la q = do
------------------------------------------------------------------------ ------------------------------------------------------------------------
flow :: (FlowCmdM env ServantErr m, FlowCorpus a, MkCorpus c) flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)
=> Maybe c -> Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId => Maybe c -> Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
flow c u cn la docs = do flow c u cn la docs = do
ids <- mapM (insertMasterDocs c la ) docs ids <- mapM (insertMasterDocs c la ) docs
flowCorpusUser (la ^. tt_lang) u cn c (concat ids) flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
flowCorpus :: (FlowCmdM env ServantErr m, FlowCorpus a) flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
=> Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId => Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
flowCorpus = flow (Nothing :: Maybe HyperdataCorpus) flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
......
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