Commit 3c30ed06 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

defaultHyperdata returns a Maybe

parent 3c1c3e9c
......@@ -143,6 +143,8 @@ nodeErrorToFrontendError ne = case ne of
-> mkFrontendErrShow $ FE_node_creation_failed_insert_node uId pId
UserHasNegativeId uid
-> mkFrontendErrShow $ FE_node_creation_failed_user_negative_id uid
NodeHasNoDefaultValue nt
-> mkFrontendErrShow $ FE_node_creation_failed_no_default_value nt
NodeLookupFailed reason
-> case reason of
NodeDoesNotExist nid
......
......@@ -209,6 +209,10 @@ newtype instance ToFrontendErrorData 'EC_400__node_creation_failed_user_negative
FE_node_creation_failed_user_negative_id { neuni_user_id :: UserId }
deriving (Show, Eq, Generic)
newtype instance ToFrontendErrorData 'EC_400__node_creation_failed_no_default_value =
FE_node_creation_failed_no_default_value { ncfdv_nodetype :: NodeType }
deriving (Show, Eq, Generic)
data instance ToFrontendErrorData 'EC_400__node_lookup_failed_user_too_many_roots =
FE_node_lookup_failed_user_too_many_roots { netmr_user_id :: UserId
, netmr_roots :: [NodeId]
......@@ -432,6 +436,14 @@ instance FromJSON (ToFrontendErrorData 'EC_400__node_creation_failed_insert_node
necin_parent_id <- o .: "parent_id"
pure FE_node_creation_failed_insert_node{..}
instance ToJSON (ToFrontendErrorData 'EC_400__node_creation_failed_no_default_value) where
toJSON FE_node_creation_failed_no_default_value{..} =
object [ "nodetype" .= toJSON ncfdv_nodetype ]
instance FromJSON (ToFrontendErrorData 'EC_400__node_creation_failed_no_default_value) where
parseJSON = withObject "FE_node_creation_failed_no_default_value" $ \o -> do
ncfdv_nodetype <- o .: "nodetype"
pure FE_node_creation_failed_no_default_value{..}
instance ToJSON (ToFrontendErrorData 'EC_500__node_generic_exception) where
toJSON FE_node_generic_exception{..} =
object [ "error" .= nege_error ]
......@@ -634,6 +646,9 @@ instance FromJSON FrontendError where
EC_400__node_creation_failed_user_negative_id -> do
(fe_data :: ToFrontendErrorData 'EC_400__node_creation_failed_user_negative_id) <- o .: "data"
pure FrontendError{..}
EC_400__node_creation_failed_no_default_value -> do
(fe_data :: ToFrontendErrorData 'EC_400__node_creation_failed_no_default_value) <- o .: "data"
pure FrontendError{..}
EC_500__node_generic_exception -> do
(fe_data :: ToFrontendErrorData 'EC_500__node_generic_exception) <- o .: "data"
pure FrontendError{..}
......
......@@ -30,6 +30,7 @@ data BackendErrorCode
| EC_400__node_creation_failed_parent_exists
| EC_400__node_creation_failed_insert_node
| EC_400__node_creation_failed_user_negative_id
| EC_400__node_creation_failed_no_default_value
| EC_500__node_generic_exception
| EC_400__node_needs_configuration
-- validation errors
......
......@@ -28,7 +28,7 @@ data HyperdataCorpus =
-- 'defaultLanguage' if we don't know which language it is.
, _hc_lang :: Maybe Lang
}
deriving (Generic, Show)
deriving (Generic, Eq, Show)
defaultHyperdataCorpus :: HyperdataCorpus
defaultHyperdataCorpus =
......
......@@ -34,7 +34,7 @@ data CorpusField = MarkdownField { _cf_text :: !Text }
, _cf_authors :: !Text
-- , _cf_resources :: ![Resource]
}
deriving (Show, Generic)
deriving (Show, Eq, Generic)
defaultCorpusField :: CorpusField
defaultCorpusField = MarkdownField "# Title"
......@@ -56,7 +56,7 @@ data HyperdataField a =
HyperdataField { _hf_type :: !CodeType
, _hf_name :: !Text
, _hf_data :: !a
} deriving (Generic, Show)
} deriving (Generic, Eq, Show)
defaultHyperdataField :: HyperdataField CorpusField
defaultHyperdataField = HyperdataField Markdown "name" defaultCorpusField
......
......@@ -14,6 +14,7 @@ Portability : POSIX
module Gargantext.Database.Admin.Types.Hyperdata.Default
where
import Prelude
import Gargantext.Database.Admin.Types.Node (NodeType(..))
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Hyperdata.Prelude
......@@ -49,7 +50,6 @@ data DefaultHyperdata =
| DefaultFrameCode HyperdataFrame
| DefaultFile HyperdataFile
| DefaultReadOnly HyperdataReadOnly
instance Hyperdata DefaultHyperdata
......@@ -83,37 +83,38 @@ instance ToJSON DefaultHyperdata where
toJSON (DefaultFrameCode x) = toJSON x
toJSON (DefaultFile x) = toJSON x
toJSON (DefaultReadOnly x) = toJSON x
defaultHyperdata :: NodeType -> DefaultHyperdata
defaultHyperdata NodeUser = DefaultUser defaultHyperdataUser
defaultHyperdata NodeContact = DefaultContact defaultHyperdataContact
defaultHyperdata NodeCorpus = DefaultCorpus defaultHyperdataCorpus
defaultHyperdata NodeCorpusV3 = DefaultCorpusV3 defaultHyperdataCorpus
defaultHyperdata NodeAnnuaire = DefaultAnnuaire defaultHyperdataAnnuaire
defaultHyperdata NodeDocument = DefaultDocument defaultHyperdataDocument
defaultHyperdata NodeTexts = DefaultTexts defaultHyperdataTexts
defaultHyperdata NodeList = DefaultList defaultHyperdataList
defaultHyperdata NodeListCooc = DefaultListCooc defaultHyperdataListCooc
defaultHyperdata NodeModel = DefaultModel defaultHyperdataModel
defaultHyperdata NodeFolder = DefaultFolder defaultHyperdataFolder
defaultHyperdata NodeFolderPrivate = DefaultFolderPrivate defaultHyperdataFolderPrivate
defaultHyperdata NodeFolderShared = DefaultFolderShared defaultHyperdataFolderShared
defaultHyperdata NodeTeam = DefaultTeam defaultHyperdataFolder
defaultHyperdata NodeFolderPublic = DefaultFolderPublic defaultHyperdataFolderPublic
defaultHyperdata NodeGraph = DefaultGraph defaultHyperdataGraph
defaultHyperdata NodePhylo = DefaultPhylo defaultHyperdataPhylo
defaultHyperdata NodeDashboard = DefaultDashboard defaultHyperdataDashboard
defaultHyperdata Notes = DefaultFrameWrite defaultHyperdataFrame
defaultHyperdata Calc = DefaultFrameCalc defaultHyperdataFrame
defaultHyperdata NodeFrameVisio = DefaultFrameVisio defaultHyperdataFrame
defaultHyperdata NodeFrameNotebook = DefaultFrameCalc defaultHyperdataFrame
defaultHyperdata NodeFile = DefaultFile defaultHyperdataFile
defaultHyperdata NodeReadOnly = DefaultReadOnly defaultHyperdataReadOnly
-- | Gets the default value for the hyperdata given the input 'NodeType'. Note that not
-- all the hyperdata type have a default. In particular, \"combinators\" type like the
-- \"NodeReadOnly\" do not have a default.
defaultHyperdata :: NodeType -> Maybe DefaultHyperdata
defaultHyperdata NodeUser = Just $ DefaultUser defaultHyperdataUser
defaultHyperdata NodeContact = Just $ DefaultContact defaultHyperdataContact
defaultHyperdata NodeCorpus = Just $ DefaultCorpus defaultHyperdataCorpus
defaultHyperdata NodeCorpusV3 = Just $ DefaultCorpusV3 defaultHyperdataCorpus
defaultHyperdata NodeAnnuaire = Just $ DefaultAnnuaire defaultHyperdataAnnuaire
defaultHyperdata NodeDocument = Just $ DefaultDocument defaultHyperdataDocument
defaultHyperdata NodeTexts = Just $ DefaultTexts defaultHyperdataTexts
defaultHyperdata NodeList = Just $ DefaultList defaultHyperdataList
defaultHyperdata NodeListCooc = Just $ DefaultListCooc defaultHyperdataListCooc
defaultHyperdata NodeModel = Just $ DefaultModel defaultHyperdataModel
defaultHyperdata NodeFolder = Just $ DefaultFolder defaultHyperdataFolder
defaultHyperdata NodeFolderPrivate = Just $ DefaultFolderPrivate defaultHyperdataFolderPrivate
defaultHyperdata NodeFolderShared = Just $ DefaultFolderShared defaultHyperdataFolderShared
defaultHyperdata NodeTeam = Just $ DefaultTeam defaultHyperdataFolder
defaultHyperdata NodeFolderPublic = Just $ DefaultFolderPublic defaultHyperdataFolderPublic
defaultHyperdata NodeGraph = Just $ DefaultGraph defaultHyperdataGraph
defaultHyperdata NodePhylo = Just $ DefaultPhylo defaultHyperdataPhylo
defaultHyperdata NodeDashboard = Just $ DefaultDashboard defaultHyperdataDashboard
defaultHyperdata Notes = Just $ DefaultFrameWrite defaultHyperdataFrame
defaultHyperdata Calc = Just $ DefaultFrameCalc defaultHyperdataFrame
defaultHyperdata NodeFrameVisio = Just $ DefaultFrameVisio defaultHyperdataFrame
defaultHyperdata NodeFrameNotebook = Just $ DefaultFrameCalc defaultHyperdataFrame
defaultHyperdata NodeFile = Just $ DefaultFile defaultHyperdataFile
defaultHyperdata NodeReadOnly = Nothing
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.ReadOnly (
HyperdataReadOnly(..)
, defaultHyperdataReadOnly
) where
import Data.Aeson.TH
import Prelude
import GHC.Generics
import Gargantext.Database.Admin.Types.Hyperdata.Any
import Gargantext.Core.Utils.Prefix (unPrefix)
import Test.QuickCheck
import Gargantext.Database.Admin.Types.Node (NodeType)
data HyperdataReadOnly =
HyperdataReadOnly { _hro_wrapped :: Maybe HyperdataAny }
data HyperdataReadOnly wrapped =
HyperdataReadOnly { _hro_wrapped_type :: NodeType
, _hro_wrapped :: Maybe wrapped
}
deriving (Generic, Show, Eq)
defaultHyperdataReadOnly :: HyperdataReadOnly
defaultHyperdataReadOnly =
HyperdataReadOnly
{ _hro_wrapped = Nothing
}
--
-- Instances
--
$(deriveJSON (unPrefix "_hro_") ''HyperdataReadOnly)
instance Arbitrary HyperdataReadOnly where
arbitrary = HyperdataReadOnly <$> arbitrary
-- | NOTE(adn) This is not a sound instance, as there is no guarantee the
-- inner type will be one of the wrapped node types, as well as that the
-- 'NodeType' will match the inner wrapped value.
instance Arbitrary wrapped => Arbitrary (HyperdataReadOnly wrapped) where
arbitrary = HyperdataReadOnly <$> arbitrary <*> arbitrary
......@@ -306,19 +306,31 @@ insertDefaultNodeIfNotExists nt p u = do
xs -> pure xs
insertNode :: (HasDBid NodeType, HasNodeError err)
=> NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> DBCmd err NodeId
insertNode nt n h p u = do
res <- insertNodesR [nodeW nt n h p u]
case res of
[x] -> pure x
_ -> nodeError $ NodeCreationFailed $ InsertNodeFailed u p
=> NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> UserId
-> DBCmd err NodeId
insertNode nt mb_n mb_h p u = do
case mb_h <|> defaultHyperdata nt of
Nothing -> nodeError $ NodeCreationFailed $ NodeHasNoDefaultValue nt
Just h -> do
res <- insertNodesR [nodeW nt n h p u]
case res of
[x] -> pure x
_ -> nodeError $ NodeCreationFailed $ InsertNodeFailed u p
where
n = fromMaybe (defaultName nt) mb_n
nodeW :: HasDBid NodeType
=> NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
nodeW nt n h p u = node nt n' h' (Just p) u
where
n' = fromMaybe (defaultName nt) n
h' = maybe (defaultHyperdata nt) identity h
=> NodeType
-> Name
-> DefaultHyperdata
-> ParentId
-> UserId
-> NodeWrite
nodeW nt n h p u = node nt n h (Just p) u
------------------------------------------------------------------------
node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
......
......@@ -30,6 +30,7 @@ import Control.Lens (Prism', (#), (^?))
import Data.Aeson (object)
import Data.Text qualified as T
import Gargantext.Core.Types.Individu ( Username )
import Gargantext.Core.Types (NodeType)
import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..), ContextId, UserId, ParentId)
import Gargantext.Prelude hiding (sum, head)
import Prelude hiding (null, id, map, sum, show)
......@@ -40,6 +41,7 @@ data NodeCreationError
| UserParentDoesNotExist UserId
| UserHasNegativeId UserId
| InsertNodeFailed UserId ParentId
| NodeHasNoDefaultValue NodeType
deriving (Show, Eq, Generic)
instance ToJSON NodeCreationError
......@@ -50,6 +52,7 @@ renderNodeCreationFailed = \case
UserParentDoesNotExist uid -> "user id " <> T.pack (show uid) <> " has no parent"
UserHasNegativeId uid -> "user id " <> T.pack (show uid) <> " is a negative id."
InsertNodeFailed uid pid -> "couldn't create the list for user id " <> T.pack (show uid) <> " and parent id " <> T.pack (show pid)
NodeHasNoDefaultValue nt -> T.pack $ "node of type " <> show nt <> " could not be given a sensible default value."
data NodeLookupError
= NodeDoesNotExist NodeId
......
......@@ -16,7 +16,6 @@ module Test.Instances
where
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Map.Strict.Patch qualified as PM
import Data.Patch.Class (Replace(Keep), replace)
import Data.Text qualified as T
......@@ -26,13 +25,15 @@ import Gargantext.API.Errors.Types qualified as Errors
import Gargantext.API.Ngrams.Types qualified as Ngrams
import Gargantext.API.Node.Corpus.New (ApiInfo(..))
import Gargantext.API.Node.Types (RenameNode(..), WithQuery(..))
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.AsyncUpdates.Dispatcher.Types qualified as DET
import Gargantext.Core.NodeStory.Types qualified as NS
import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
import Gargantext.Core.Notifications.Dispatcher.Types qualified as DET
import Gargantext.Core.NodeStory.Types qualified as NS
import Gargantext.Core.Text.Ngrams (NgramsType(..))
import Gargantext.Core.Types.Main (ListType(CandidateTerm, StopTerm, MapTerm))
import Gargantext.Database.Admin.Types.Node (UserId(UnsafeMkUserId))
import Gargantext.Database.Admin.Types.Hyperdata qualified as Hyperdata
import Gargantext.Database.Admin.Types.Node (UserId(UnsafeMkUserId), NodeType(..))
import Gargantext.Prelude hiding (replace, Location)
import Servant.Job.Core qualified as SJ
import Servant.Job.Types qualified as SJ
......@@ -282,6 +283,8 @@ genFrontendErr be = do
pure $ Errors.mkFrontendErr' txt $ Errors.FE_node_creation_failed_insert_node parentId userId
Errors.EC_400__node_creation_failed_user_negative_id
-> pure $ Errors.mkFrontendErr' txt (Errors.FE_node_creation_failed_user_negative_id (UnsafeMkUserId (-42)))
Errors.EC_400__node_creation_failed_no_default_value
-> pure $ Errors.mkFrontendErr' txt (Errors.FE_node_creation_failed_no_default_value NodeReadOnly)
Errors.EC_500__node_generic_exception
-> do err <- arbitrary
pure $ Errors.mkFrontendErr' txt $ Errors.FE_node_generic_exception err
......
......@@ -64,7 +64,7 @@ tests = testGroup "JSON" [
, testProperty "ObjectData" (jsonRoundtrip @ObjectData)
, testProperty "PhyloData" (jsonRoundtrip @PhyloData)
, testProperty "LayerData" (jsonRoundtrip @LayerData)
, testProperty "HyperdataReadOnly" (jsonRoundtrip @HyperdataReadOnly)
, testProperty "HyperdataReadOnly HyperdataCorpus" (jsonRoundtrip @(HyperdataReadOnly HyperdataCorpus))
, testCase "can parse bpa_phylo_test.json" testParseBpaPhylo
, testCase "can parse open_science.json" testOpenSciencePhylo
]
......
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