WIP

parent 7408a02c
......@@ -42,7 +42,8 @@ import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
--import Data.Maybe (catMaybes)
--import qualified Data.Map.Strict as DM
import qualified Data.Map.Strict as DM
import Data.Map.Strict (Map)
--import qualified Data.Set as Set
import Control.Lens ((.~))
import Data.Aeson
......@@ -183,27 +184,14 @@ instance ToSchema NgramsPatch
instance Arbitrary NgramsPatch where
arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
data NgramsIdPatch =
NgramsIdPatch { _nip_ngrams :: NgramsTerm
, _nip_ngramsPatch :: NgramsPatch
}
deriving (Ord, Eq, Show, Generic)
$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
instance ToSchema NgramsIdPatch
instance Arbitrary NgramsIdPatch where
arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
--
-- TODO:
-- * This should be a Map NgramsId NgramsPatch
-- * Patchs -> Patches
newtype NgramsIdPatchs =
NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
newtype NgramsTablePatch =
NgramsTablePatch { _nip_ngramsIdPatchs :: Map NgramsTerm NgramsPatch }
deriving (Ord, Eq, Show, Generic, Arbitrary)
$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
instance ToSchema NgramsIdPatchs
$(deriveJSON (unPrefix "_nip_") ''NgramsTablePatch)
instance ToSchema NgramsTablePatch
------------------------------------------------------------------------
------------------------------------------------------------------------
......@@ -243,6 +231,7 @@ type TableNgramsApiGet = Summary " Table Ngrams API Get"
type TableNgramsApi = Summary " Table Ngrams API Change"
:> QueryParam "list" ListId
<<<<<<< HEAD
:> ReqBody '[JSON] NgramsIdPatchsFeed -- Versioned ...
:> Put '[JSON] NgramsIdPatchsBack -- Versioned ...
......@@ -250,15 +239,60 @@ type NgramsIdPatchsFeed = NgramsIdPatchs
type NgramsIdPatchsBack = NgramsIdPatchs
||||||| parent of 06bfb6e... WIP
:> ReqBody '[JSON] NgramsIdPatchsFeed -- Versioned ...
:> Put '[JSON] NgramsIdPatchsBack -- Versioned ...
type NgramsIdPatchsFeed = NgramsIdPatchs
type NgramsIdPatchsBack = NgramsIdPatchs
defaultList :: Connection -> CorpusId -> IO ListId
defaultList c cId = view node_id <$> maybe (panic noListFound) identity
<$> head
<$> getListsWithParentId c cId
where
noListFound = "Gargantext.API.Ngrams.defaultList: no list found"
=======
:> ReqBody '[JSON] (Versioned NgramsTablePatch)
:> Put '[JSON] (Versioned NgramsTablePatch)
data NgramError = NoListFound
deriving (Show)
class HasNgramError e where
_NgramError :: Prism' e NgramError
instance HasNgramError ServantErr where
_NgramError = prism' mk (const Nothing) -- Note a prism
where
mk NoListFound = err404 { errBody = "NgramError: No list found" }
mk EmptyRoot = err500 { errBody = "Root node should not be empty" }
mk TooManyRoots = err500 { errBody = "Too many root nodes" }
ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
ngramError nne = throwError $ _NgramError # nne
defaultList :: ( MonadError e m
, HasNgramError e
, MonadReader env m
, HasConnection env
) => CorpusId -> m ListId
defaultList cId = view node_id =<< maybe (ngramError NoListFound) pure
<$> head
<$> getListsWithParentId cId
>>>>>>> 06bfb6e... WIP
{-
toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
toLists :: ListId -> NgramsTablePatch -> [(ListId, NgramsId, ListTypeId)]
-- toLists = undefined
toLists lId np = [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
toList = undefined
toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsTablePatch -> [NodeNgramsNgrams]
toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
......@@ -268,22 +302,34 @@ toGroup lId addOrRem (NgramsIdPatch ngId patch) =
-}
tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
tableNgramsPatch = undefined
-- Apply the given patch to the DB and returns the patch to be applied on the
-- cilent.
-- TODO:
-- In this perliminary version the OT aspect is missing, therefore the version
-- number is always 1 and the returned patch is always empty.
tableNgramsPatch :: ( MonadError e m
, HasNgramError e
, MonadReader env m
, HasConnection env
, MonadIO m
)
=> CorpusId -> Maybe ListId
-> Versioned NgramsTablePatch
-> m (Versioned NgramsTablePatch)
tableNgramsPatch conn corpusId maybeList (Versioned version patch) = do
when (version /= 1) $ ngramError $ UnsupportedVersion v
listId <- maybe defaultList pure maybeList
{-
tableNgramsPatch conn corpusId maybeList patchs = do
listId <- case maybeList of
Nothing -> defaultList conn corpusId
Just listId' -> pure listId'
_ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
_ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
_ <- updateNodeNgrams conn (toLists listId patchs)
pure (NgramsIdPatchs [])
_ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patch
_ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patch
_ <- updateNodeNgrams conn (toLists listId patch)
-}
pure $ Version 1 mempty
-- | TODO Errors management
-- TODO: polymorphic for Annuaire or Corpus or ...
getTableNgrams :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
-- getTableNgrams :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
getTableNgrams :: Connection -> CorpusId -> Handler TableNgramsApiGet
getTableNgrams c cId maybeTabType maybeListId = do
let lieu = "Garg.API.Ngrams: " :: Text
let ngramsType = case maybeTabType of
......
......@@ -252,6 +252,13 @@ graphAPI _ _ = do
-- liftIO $ liftIO $ pure $ maybe t identity maybeGraph
-- TODO what do we get about the node? to replace contextText
instance HasNodeError ServantErr where
_NodeError = prism' make match
where
err = err404 { errBody = "NodeError: No list found" }
make NoListFound = err
match = guard (== err) $> NoListFound
-- 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
......
......@@ -19,6 +19,7 @@ Ngrams connection to the Database.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.Ngrams where
......@@ -44,7 +45,7 @@ import Gargantext.Database.Config (nodeTypeId,userMaster)
import Gargantext.Database.Root (getRoot)
import Gargantext.Database.Types.Node (NodeType)
import Gargantext.Database.Schema.Node (getListsWithParentId, getCorporaWithParentId)
import Gargantext.Database.Utils (mkCmd, Cmd(..))
import Gargantext.Database.Utils (mkCmd, Cmd(..), Cmd')
import Gargantext.Prelude
import Opaleye
import Prelude (Enum, Bounded, minBound, maxBound)
......@@ -198,25 +199,24 @@ queryInsertNgrams = [sql|
-- TODO: the way we are getting main Master Corpus and List ID is not clean
-- TODO: if ids are not present -> create
-- TODO: Global Env State Monad to keep in memory the ids without retrieving it each time
getNgramsTableDb :: DPS.Connection
-> NodeType -> NgramsType
getNgramsTableDb :: NodeType -> NgramsType
-> NgramsTableParamUser
-> IO ([NgramsTableData], MapToParent, MapToChildren)
getNgramsTableDb c nt ngrt ntp@(NgramsTableParam listIdUser _) = do
-> Cmd' err ([NgramsTableData], MapToParent, MapToChildren)
getNgramsTableDb nt ngrt ntp@(NgramsTableParam listIdUser _) = do
maybeRoot <- head <$> getRoot userMaster c
maybeRoot <- head <$> getRoot userMaster
let path = "Garg.Db.Ngrams.getTableNgrams: "
let masterRootId = maybe (panic $ path <> "no userMaster Tree") (view node_id) maybeRoot
-- let errMess = panic "Error"
corpusMasterId <- maybe (panic "error master corpus") (view node_id) <$> head <$> getCorporaWithParentId c masterRootId
corpusMasterId <- maybe (panic "error master corpus") (view node_id) <$> head <$> getCorporaWithParentId masterRootId
listMasterId <- maybe (panic "error master list") (view node_id) <$> head <$> getListsWithParentId c corpusMasterId
listMasterId <- maybe (panic "error master list") (view node_id) <$> head <$> getListsWithParentId corpusMasterId
ngramsTableData <- getNgramsTableData c nt ngrt ntp (NgramsTableParam listMasterId corpusMasterId)
ngramsTableData <- getNgramsTableData nt ngrt ntp (NgramsTableParam listMasterId corpusMasterId)
(mapToParent,mapToChildren) <- getNgramsGroup c listIdUser listMasterId
(mapToParent,mapToChildren) <- getNgramsGroup listIdUser listMasterId
pure (ngramsTableData, mapToParent,mapToChildren)
......
......@@ -20,13 +20,16 @@ Portability : POSIX
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.Node where
import Control.Arrow (returnA)
import Control.Lens (set)
import Control.Lens (Prism', set, view, (#), (^?))
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Aeson
import Data.ByteString (ByteString)
import Data.Maybe (Maybe(..), fromMaybe)
......@@ -53,8 +56,26 @@ import qualified Data.ByteString.Lazy as DBL
import qualified Data.Profunctor.Product as PP
------------------------------------------------------------------------
instance FromField HyperdataAny
where
data NodeError = NoListFound
deriving (Show)
class HasNodeError e where
_NodeError :: Prism' e NodeError
nodeError :: (MonadError e m, HasNodeError e) => NodeError -> m a
nodeError ne = throwError $ _NodeError # ne
catchNodeError :: (MonadError e m, HasNodeError e) => m a -> (NodeError -> m a) -> m a
catchNodeError f g = catchError f (\e -> maybe (throwError e) g (e ^? _NodeError))
------------------------------------------------------------------------
type AnnuaireId = Int
type DocId = Int
type TypeId = Int
------------------------------------------------------------------------
instance FromField HyperdataAny where
fromField = fromField'
instance FromField HyperdataCorpus
......@@ -290,11 +311,6 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
returnA -< node
--type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
-- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
-- deleteNode :: Int -> Cmd' Int
deleteNode :: Int -> Cmd Int
deleteNode n = mkCmd $ \conn ->
......@@ -330,8 +346,8 @@ getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just Nod
getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
getListsWithParentId :: Connection -> Int -> IO [Node HyperdataList]
getListsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeList)
getListsWithParentId :: Int -> Cmd' err [Node HyperdataList]
getListsWithParentId n = runQuery' $ selectNodesWith' n (Just NodeList)
getCorporaWithParentId :: Connection -> Int -> IO [Node HyperdataCorpus]
getCorporaWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeCorpus)
......@@ -470,20 +486,21 @@ node2row (Node id tn ud pid nm dt hp) = ((pgInt4 <$> id)
,(pgStrictJSONB hp)
)
------------------------------------------------------------------------
insertNodesR' :: [NodeWrite'] -> Cmd [Int]
insertNodesR' ns = mkCmd $ \c -> insertNodesR ns c
insertNodes :: [NodeWrite'] -> Cmd' err Int64
insertNodes ns = do
conn <- view connection
liftIO $ runInsertMany conn nodeTable' (map node2row ns)
insertNodes :: [NodeWrite'] -> Connection -> IO Int64
insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
insertNodesR :: [NodeWrite'] -> Cmd' err [Int]
insertNodesR ns = do
conn <- view connection
liftIO $ runInsert_ conn (Insert nodeTable' (node2row <$> ns) (rReturning (\(i,_,_,_,_,_,_) -> i)) Nothing)
insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
-------------------------
insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Cmd' err Int64
insertNodesWithParent pid ns = insertNodes (set node_parentId pid <$> ns)
insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Cmd' err [Int]
insertNodesWithParentR pid ns = insertNodesR (set node_parentId pid <$> ns)
------------------------------------------------------------------------
-- TODO Hierachy of Nodes
-- post and get same types Node' and update if changes
......@@ -565,72 +582,53 @@ childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a c
mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
mk c nt pId name = mk' c nt userId pId name
mk :: NodeType -> Maybe ParentId -> Text -> Cmd' err [Int]
mk nt pId name = mk' nt userId pId name
where
userId = 1
mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
mk' c nt uId pId name = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
mk' :: NodeType -> UserId -> Maybe ParentId -> Text -> Cmd' err [Int]
mk' nt uId pId name = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId]
where
hd = HyperdataUser . Just . pack $ show EN
type Name = Text
mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
mk'' NodeUser Nothing uId name = mkCmd $ \c -> mk' c NodeUser uId Nothing name
mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd' err [Int]
mk'' NodeUser Nothing uId name = mk' NodeUser uId Nothing name
mk'' NodeUser _ _ _ = panic "NodeUser do not have any parent"
mk'' _ Nothing _ _ = panic "NodeType does have a parent"
mk'' nt pId uId name = mkCmd $ \c -> mk' c nt uId pId name
mk'' nt pId uId name = mk' nt uId pId name
mkRoot :: Username -> UserId -> Cmd [Int]
mkRoot :: Username -> UserId -> Cmd' err [Int]
mkRoot uname uId = case uId > 0 of
False -> panic "UserId <= 0"
True -> mk'' NodeUser Nothing uId uname
mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd' err [Int]
mkCorpus n h p u = insertNodesR [nodeCorpusW n h p u]
--{-
getOrMkList :: ParentId -> UserId -> Cmd Int
getOrMkList pId uId = do
maybeList <- defaultListSafe' pId
case maybeList of
Nothing -> maybe (panic "no list") identity <$> headMay <$> mkList pId uId
Just x -> pure x
defaultListSafe' :: CorpusId -> Cmd (Maybe ListId)
defaultListSafe' cId = mkCmd $ \c -> do
maybeNode <- headMay <$> getListsWithParentId c cId
case maybeNode of
Nothing -> pure Nothing
(Just node) -> pure $ Just $ _node_id node
--}
getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd' err Int
getOrMkList pId uId =
defaultList pId
`catchNodeError`
(\NoListFound -> maybe (nodeError NoListFound) pure . headMay =<< mkList pId uId)
defaultListSafe :: Connection -> CorpusId -> IO (Maybe ListId)
defaultListSafe c cId = do
maybeNode <- headMay <$> getListsWithParentId c cId
case maybeNode of
Nothing -> pure Nothing
(Just node) -> pure $ Just $ _node_id node
defaultList :: Connection -> CorpusId -> IO ListId
defaultList c cId = maybe (panic errMessage) identity <$> defaultListSafe c cId
where
errMessage = "Gargantext.API.Ngrams.defaultList: no list found"
defaultList :: HasNodeError err => CorpusId -> Cmd' err ListId
defaultList cId =
maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
mkList :: ParentId -> UserId -> Cmd [Int]
mkList p u = insertNodesR' [nodeListW Nothing Nothing p u]
mkList :: HasNodeError err => ParentId -> UserId -> Cmd' err [Int]
mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
mkGraph :: ParentId -> UserId -> Cmd [Int]
mkGraph p u = insertNodesR' [nodeGraphW Nothing Nothing p u]
mkGraph :: ParentId -> UserId -> Cmd' err [Int]
mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
mkDashboard :: ParentId -> UserId -> Cmd [Int]
mkDashboard p u = insertNodesR' [nodeDashboardW Nothing Nothing p u]
mkDashboard :: ParentId -> UserId -> Cmd' err [Int]
mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
mkAnnuaire :: ParentId -> UserId -> Cmd [Int]
mkAnnuaire p u = insertNodesR' [nodeAnnuaireW Nothing Nothing p u]
mkAnnuaire :: ParentId -> UserId -> Cmd' err [Int]
mkAnnuaire p u = insertNodesR [nodeAnnuaireW Nothing Nothing p u]
-- | Default CorpusId Master and ListId Master
......@@ -38,7 +38,7 @@ import Gargantext.Core.Types.Main (ListId, ListTypeId)
import Gargantext.Database.Utils (mkCmd, Cmd(..))
import Gargantext.Prelude
import Opaleye
import qualified Database.PostgreSQL.Simple as PGS (Connection, query, Only(..))
import qualified Database.PostgreSQL.Simple as PGS (query, Only(..))
-- | TODO : remove id
data NodeNgramPoly id node_id ngram_id weight ngrams_type
......@@ -108,8 +108,8 @@ insertNodeNgramW nns =
type NgramsText = Text
updateNodeNgrams :: PGS.Connection -> [(ListId, NgramsText, ListTypeId)] -> IO [PGS.Only Int]
updateNodeNgrams c input = PGS.query c updateQuery (PGS.Only $ Values fields $ input)
updateNodeNgrams :: [(ListId, NgramsText, ListTypeId)] -> Cmd [PGS.Only Int]
updateNodeNgrams input = mkCmd $ \c -> PGS.query c updateQuery (PGS.Only $ Values fields $ input)
where
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
updateQuery = [sql| UPDATE nodes_ngrams as old SET
......
......@@ -15,11 +15,14 @@ commentary with @some markup@.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Utils where
import Control.Applicative (Applicative)
import Control.Lens (Getter, view)
import Control.Monad.Reader
import Control.Monad.Error.Class
import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
import Data.Either.Extra (Either(Left, Right))
import Data.Ini (readIniFile, lookupValue)
......@@ -33,12 +36,31 @@ import Database.PostgreSQL.Simple (Connection, connect)
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal (Field)
import Gargantext.Prelude
import Opaleye (Query, Unpackspec, showSqlForPostgres)
import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
import System.IO (FilePath)
import Text.Read (read)
import qualified Data.ByteString as DB
import qualified Database.PostgreSQL.Simple as PGS
class HasConnection env where
connection :: Getter env Connection
instance HasConnection Connection where
connection = identity
type Cmd' err a =
forall m env.
( MonadReader env m
, HasConnection env
, MonadError err m
, MonadIO m
) => m a
runQuery' :: Default FromFields fields haskells => Select fields -> Cmd' err [haskells]
runQuery' q = do
c <- view connection
liftIO $ runQuery c q
------------------------------------------------------------------------
{- | Reader Monad reinvented here:
......@@ -60,7 +82,6 @@ runCmd c (Cmd f) = runReaderT f c
mkCmd :: (Connection -> IO a) -> Cmd a
mkCmd = Cmd . ReaderT
------------------------------------------------------------------------
databaseParameters :: FilePath -> IO PGS.ConnectInfo
......
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