[TREE]: Add TreeError, HasTreeError and use it throw ServantErr in treeAPI

src/Gargantext/API/Node.hs

@@ -10,7 +10,7 @@ Portability : POSIX
 Node API
 -}
 
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
 
 {-# LANGUAGE NoImplicitPrelude  #-}
 {-# LANGUAGE DataKinds          #-}
@@ -23,6 +23,7 @@ module Gargantext.API.Node
       where
 -------------------------------------------------------------------
 
+import Control.Lens (prism')
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad ((>>))
 --import System.IO (putStrLn, readFile)
@@ -44,7 +45,7 @@ import Gargantext.Database.Node ( getNodesWithParentId
                                 , deleteNode, deleteNodes)
 import Gargantext.Database.Facet (FacetDoc, getDocFacet
                                  ,FacetChart)
-import Gargantext.Database.Tree (treeDB)
+import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
 
 -- Graph
 import Gargantext.TextFlow
@@ -115,10 +116,17 @@ type GraphAPI   = Get '[JSON] Graph
 graphAPI :: Connection -> NodeId -> Server GraphAPI
 graphAPI _ _ = liftIO $ textFlow (Mono EN) (Contexts contextText)
 
+-- TODO(orphan): There should be a proper APIError data type with a case TreeError.
+instance HasTreeError ServantErr where
+  _TreeError = prism' mk (const Nothing) -- Note a prism
+    where
+      mk NoRoot       = err404 { errBody = "Root node not found" }
+      mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
+      mk TooManyRoots = err500 { errBody = "Too many root nodes" }
+
 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 treeAPI :: Connection -> NodeId -> Server TreeAPI
-treeAPI c n = liftIO $ treeDB c n
-
+treeAPI = treeDB
 
 nodeAPI :: Connection -> NodeId -> Server NodeAPI
 nodeAPI conn id =  liftIO (putStrLn ("/node" :: Text) >> getNode              conn id )

src/Gargantext/Database/Tree.hs

@@ -15,10 +15,13 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE QuasiQuotes #-}
 
-module Gargantext.Database.Tree (treeDB) where
+module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..)) where
 
+import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
+import Control.Monad.Error.Class (MonadError(throwError))
+import Control.Monad.IO.Class (MonadIO(liftIO))
 import Data.Map (Map, fromListWith, lookup)
-import Data.Text (Text, pack)
+import Data.Text (Text)
 import Database.PostgreSQL.Simple
 import Database.PostgreSQL.Simple.SqlQQ
 
@@ -31,26 +34,38 @@ import Gargantext.Database.Config (typeId2node)
 -- treeTest :: IO (Tree NodeTree)
 -- treeTest = connectGargandb "gargantext.ini" >>= \c -> treeDB c 347474
 ------------------------------------------------------------------------
+
+data TreeError = NoRoot | EmptyRoot | TooManyRoots
+  deriving (Show)
+
+class HasTreeError e where
+  _TreeError :: Prism' e TreeError
+
+treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
+treeError te = throwError $ _TreeError # te
+
 -- | Returns the Tree of Nodes in Database
-treeDB :: Connection -> RootId -> IO (Tree NodeTree)
-treeDB c r = toTree <$> toTreeParent <$> dbTree c r
+treeDB :: (MonadIO m, MonadError e m, HasTreeError e)
+       => Connection -> RootId -> m (Tree NodeTree)
+treeDB c r = toTree =<< (toTreeParent <$> liftIO (dbTree c r))
 
 type RootId = Int
 type ParentId = Int
 ------------------------------------------------------------------------
-toTree :: Map (Maybe ParentId) [DbTreeNode] -> Tree NodeTree
-toTree m = toTree' m n
-  where
-    n = case lookup Nothing m of
-        Nothing   -> panic $ pack "no root"
-        Just []   -> panic $ pack "empty root"
-        Just [n'] -> n'
-        Just _    -> panic $ pack "too many roots"
+toTree :: (MonadError e m, HasTreeError e)
+       => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
+toTree m =
+    case lookup Nothing m of
+        Just [n] -> pure $ toTree' m n
+        Nothing  -> treeError NoRoot
+        Just []  -> treeError EmptyRoot
+        Just _   -> treeError TooManyRoots
 
 toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
-toTree' m n = case lookup (Just $ dt_nodeId n) m of
-         Nothing    -> TreeN (toNodeTree n) []
-         Just  ns   -> TreeN (toNodeTree n) (map (toTree' m) ns)
+toTree' m n =
+  TreeN (toNodeTree n) $
+    m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
+
 
 ------------------------------------------------------------------------
 toNodeTree :: DbTreeNode -> NodeTree