Skip to content

H
haskell-gargantext
Commit 1aa7eefa authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

Merge branch 'dev' into dev-doc-annotation-issue

parents 44a2d2ad b3ad95a1
Show whitespace changes
Inline Side-by-side
Showing with 870 additions and 380 deletions
devops/postgres/schema.sql
View file @ 1aa7eefa
......@@ -92,10 +92,11 @@ CREATE TABLE public.nodes_nodes (
node2_id INTEGER NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
score REAL,
category INTEGER,
PRIMARY KEY (node1_id,node2_id)
PRIMARY KEY (node1_id, node2_id)
);
ALTER TABLE public.nodes_nodes OWNER TO gargantua;
---------------------------------------------------------------
CREATE TABLE public.node_node_ngrams (
node1_id INTEGER NOT NULL REFERENCES public.nodes (id) ON DELETE CASCADE,
......@@ -107,7 +108,6 @@ PRIMARY KEY (node1_id, node2_id, ngrams_id, ngrams_type)
);
ALTER TABLE public.node_node_ngrams OWNER TO gargantua;
CREATE TABLE public.node_node_ngrams2 (
node_id INTEGER NOT NULL REFERENCES public.nodes (id) ON DELETE CASCADE,
nodengrams_id INTEGER NOT NULL REFERENCES public.node_ngrams (id) ON DELETE CASCADE,
......
gargantext.ini_toModify
View file @ 1aa7eefa
......@@ -4,9 +4,18 @@ MASTER_USER = gargantua
# SECURITY WARNING: keep the secret key used in production secret!
SECRET_KEY = PASSWORD_TO_CHANGE
# Frames
FRAME_WRITE_URL = URL_TO_CHANGE
FRAME_CALC_URL = URL_TO_CHANGE
[network]
# Emails From address (sent by smtp)
MAIL = username@gargantext.org
HOST = localhost
# if remote smtp host
# HOST_USER = user
# HOST_password = password
[database]
# PostgreSQL access
DB_HOST = 127.0.0.1
......@@ -14,7 +23,8 @@ DB_PORT = 5432
DB_NAME = gargandbV5
DB_USER = gargantua
DB_PASS = PASSWORD_TO_CHANGE
# Logs
[logs]
LOG_FILE = /var/log/gargantext/backend.log
LOG_LEVEL = DEBUG
LOG_FORMATTER = verbose
package.yaml
View file @ 1aa7eefa
......@@ -208,6 +208,16 @@ library:
- servant-xml
- simple-reflect
- singletons # (IGraph)
# for mail
- smtp-mail
- mime-mail
# for password generation
- cprng-aes
- binary
- crypto-random
- split
- stemmer
- string-conversions
......
src/Gargantext/API/HashedResponse.hs
View file @ 1aa7eefa
......@@ -5,7 +5,7 @@ import Data.Swagger
import Data.Text (Text)
import Gargantext.Prelude
import qualified Gargantext.Prelude.Utils as Crypto (hash)
import qualified Gargantext.Core.Crypto.Hash as Crypto (hash)
import GHC.Generics (Generic)
data HashedResponse a = HashedResponse { hash :: Text, value :: a }
......
src/Gargantext/API/Ngrams/List.hs
View file @ 1aa7eefa
......@@ -55,7 +55,6 @@ instance ToJSON a => MimeRender HTML a where
mimeRender _ = encode
------------------------------------------------------------------------
get :: RepoCmdM env err m =>
ListId -> m (Headers '[Header "Content-Disposition" Text] NgramsList)
get lId = do
......@@ -74,7 +73,6 @@ get' lId = fromList
<$> mapM (getNgramsTableMap lId) ngramsTypes
------------------------------------------------------------------------
-- TODO : purge list
post :: FlowCmdM env err m
=> ListId
......@@ -88,7 +86,6 @@ post l m = do
------------------------------------------------------------------------
------------------------------------------------------------------------
type PostAPI = Summary "Update List"
:> "add"
:> "form"
......
src/Gargantext/API/Ngrams/Tools.hs
View file @ 1aa7eefa
......@@ -67,15 +67,18 @@ getTermsWith f ls ngt lt = Map.fromListWith (<>)
Nothing -> (f'' t, [])
Just r -> (f'' r, map f'' [t])
mapTermListRoot :: [ListId] -> NgramsType
-> NgramsRepo -> Map Text (ListType, (Maybe Text))
mapTermListRoot :: [ListId]
-> NgramsType
-> NgramsRepo
-> Map Text (ListType, (Maybe Text))
mapTermListRoot nodeIds ngramsType repo =
Map.fromList [ (t, (_nre_list nre, _nre_root nre))
| (t, nre) <- Map.toList ngrams
]
where ngrams = listNgramsFromRepo nodeIds ngramsType repo
filterListWithRoot :: ListType -> Map Text (ListType, Maybe Text)
filterListWithRoot :: ListType
-> Map Text (ListType, Maybe Text)
-> Map Text (Maybe RootTerm)
filterListWithRoot lt m = Map.fromList
$ map (\(t,(_,r)) -> (t,r))
......
src/Gargantext/API/Node/Contact.hs 0 → 100644
View file @ 1aa7eefa
{-|
Module : Gargantext.API.Node.Contact
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Gargantext.API.Node.Contact
where
import Data.Aeson
import Data.Either (Either(Right))
import Data.Maybe (Maybe(..))
import Data.Swagger
import Data.Text (Text)
import GHC.Generics (Generic)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
import Gargantext.API.Admin.Settings (HasSettings)
import Gargantext.API.Node
import Gargantext.API.Node.Corpus.New (AsyncJobs)
import Gargantext.API.Prelude (GargServer, simuLogs)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Flow (flow)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAnnuaire(..), HyperdataContact)
import Gargantext.Database.Admin.Types.Hyperdata.Contact (hyperdataContact)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Prelude (($), liftBase, (.), printDebug, pure)
import Gargantext.Text.Terms (TermType(..))
import Servant
import Servant.Job.Async (JobFunction(..), serveJobsAPI)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
------------------------------------------------------------------------
type API = "contact" :> Summary "Contact endpoint"
:> API_Async
:<|> Capture "contact_id" NodeId
:> NodeNodeAPI HyperdataContact
api :: UserId -> CorpusId -> GargServer API
api uid cid = (api_async (RootId (NodeId uid)) cid)
:<|> (nodeNodeAPI (Proxy :: Proxy HyperdataContact) uid cid)
type API_Async = AsyncJobs JobLog '[JSON] AddContactParams JobLog
------------------------------------------------------------------------
data AddContactParams = AddContactParams { firstname :: !Text, lastname :: !Text }
| AddContactParamsAdvanced { firstname :: !Text
, lastname :: !Text
-- TODO add others fields
}
deriving (Generic)
----------------------------------------------------------------------
api_async :: User -> NodeId -> GargServer API_Async
api_async u nId =
serveJobsAPI $
JobFunction (\p log ->
let
log' x = do
printDebug "addContact" x
liftBase $ log x
in addContact u nId p (liftBase . log')
)
addContact :: (HasSettings env, FlowCmdM env err m)
=> User
-> NodeId
-> AddContactParams
-> (JobLog -> m ())
-> m JobLog
addContact u nId (AddContactParams fn ln) logStatus = do
logStatus JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_events = Just []
}
_ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) [[hyperdataContact fn ln]]
pure JobLog { _scst_succeeded = Just 2
, _scst_failed = Just 0
, _scst_remaining = Just 0
, _scst_events = Just []
}
addContact _uId _nId _p logStatus = do
simuLogs logStatus 10
------------------------------------------------------------------------
-- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
instance FromJSON AddContactParams where
parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
instance ToJSON AddContactParams where
toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
instance ToSchema AddContactParams
instance Arbitrary AddContactParams where
arbitrary = elements [AddContactParams "Pierre" "Dupont"]
------------------------------------------------------------------------
src/Gargantext/API/Node/Corpus/Annuaire.hs
View file @ 1aa7eefa
......@@ -74,30 +74,11 @@ addToAnnuaireWithForm _cid (AnnuaireWithForm ft _d _l) logStatus = do
printDebug "ft" ft
-- let
-- parse = case ft of
-- CSV_HAL -> Parser.parseFormat Parser.CsvHal
-- CSV -> Parser.parseFormat Parser.CsvGargV3
-- WOS -> Parser.parseFormat Parser.WOS
-- PresseRIS -> Parser.parseFormat Parser.RisPresse
-- docs <- liftBase
-- $ splitEvery 500
-- <$> take 1000000
-- <$> parse (cs d)
logStatus JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_events = Just []
}
-- cid' <- flowCorpus "user1"
-- (Right [cid])
-- (Multi $ fromMaybe EN l)
-- (map (map toHyperdataDocument) docs)
-- printDebug "cid'" cid'
pure JobLog { _scst_succeeded = Just 2
, _scst_failed = Just 0
, _scst_remaining = Just 0
......
src/Gargantext/API/Node/Corpus/Export.hs
View file @ 1aa7eefa
......@@ -19,22 +19,19 @@ Main exports of Gargantext:
module Gargantext.API.Node.Corpus.Export
where
import Data.Aeson.TH (deriveJSON)
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Swagger
import Data.Text (Text)
import GHC.Generics (Generic)
import Servant
import Gargantext.API.Ngrams
import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo)
import Gargantext.API.Prelude (GargNoServer)
import Gargantext.Core.Types --
import Gargantext.Core.Crypto.Hash (hash)
import Gargantext.Core.Types
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Action.Metrics.NgramsByNode (getNgramsByNodeOnlyUser)
import Gargantext.Database.Admin.Config (userMaster)
......@@ -42,13 +39,16 @@ import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
import Gargantext.Database.Admin.Types.Node (Node, NodeId, ListId, CorpusId)
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
import Gargantext.Database.Query.Table.NodeNode (selectDocNodes)
import Gargantext.Database.Schema.Node (_node_id, _node_hyperdata)
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Database.Schema.Node (_node_id, _node_hyperdata)
import Gargantext.Prelude
import Gargantext.Prelude.Utils (hash)
import Servant
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
-- Corpus Export
......
src/Gargantext/API/Node/Corpus/New.hs
View file @ 1aa7eefa
......@@ -213,12 +213,12 @@ addToCorpusWithQuery u cid (WithQuery q dbs l _nid) logStatus = do
, _scst_remaining = Just 5
, _scst_events = Just []
}
printDebug "addToCorpusWithQuery" cid
printDebug "addToCorpusWithQuery" (cid, dbs)
-- TODO add cid
-- TODO if cid is folder -> create Corpus
-- if cid is corpus -> add to corpus
-- if cid is root -> create corpus in Private
txts <- mapM (\db -> getDataText db (Multi l) q (Just 10000)) [database2origin dbs]
txts <- mapM (\db -> getDataText db (Multi l) q Nothing) [database2origin dbs]
logStatus JobLog { _scst_succeeded = Just 2
, _scst_failed = Just 0
......
src/Gargantext/API/Node/Corpus/New/File.hs
View file @ 1aa7eefa
......@@ -30,7 +30,7 @@ import Gargantext.API.Ngrams (TODO)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude -- (Cmd, CmdM)
import Gargantext.Prelude
import Gargantext.Prelude.Utils (hash)
import Gargantext.Core.Crypto.Hash (hash)
import Servant
import Servant.Multipart
import Servant.Swagger (HasSwagger(toSwagger))
......
src/Gargantext/API/Node/Update.hs
View file @ 1aa7eefa
......@@ -41,10 +41,10 @@ type API = Summary " Update node according to NodeType params"
:> AsyncJobs JobLog '[JSON] UpdateNodeParams JobLog
------------------------------------------------------------------------
data UpdateNodeParams = UpdateNodeParamsList { methodList :: Method }
| UpdateNodeParamsGraph { methodGraph :: GraphMetric }
| UpdateNodeParamsTexts { methodTexts :: Granularity }
| UpdateNodeParamsBoard { methodBoard :: Charts }
data UpdateNodeParams = UpdateNodeParamsList { methodList :: !Method }
| UpdateNodeParamsGraph { methodGraph :: !GraphMetric }
| UpdateNodeParamsTexts { methodTexts :: !Granularity }
| UpdateNodeParamsBoard { methodBoard :: !Charts }
deriving (Generic)
----------------------------------------------------------------------
......
src/Gargantext/API/Routes.hs
View file @ 1aa7eefa
......@@ -7,7 +7,6 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
......@@ -51,7 +50,7 @@ import qualified Gargantext.API.Node.Corpus.Annuaire as Annuaire
import qualified Gargantext.API.Node.Corpus.Export as Export
import qualified Gargantext.API.Node.Corpus.New as New
import qualified Gargantext.API.Public as Public
import qualified Gargantext.API.Node.Contact as Contact
type GargAPI = "api" :> Summary "API " :> GargAPIVersion
-- | TODO :<|> Summary "Latest API" :> GargAPI'
......@@ -116,9 +115,7 @@ type GargPrivateAPI' =
:<|> "annuaire" :> Summary "Contact endpoint"
:> Capture "annuaire_id" NodeId
:> "contact"
:> Capture "contact_id" NodeId
:> NodeNodeAPI HyperdataContact
:> Contact.API
-- Document endpoint
:<|> "document" :> Summary "Document endpoint"
......@@ -208,7 +205,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
:<|> nodeNodeAPI (Proxy :: Proxy HyperdataAny) uid
:<|> Export.getCorpus -- uid
:<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire) uid
:<|> nodeNodeAPI (Proxy :: Proxy HyperdataContact) uid
:<|> Contact.api uid
:<|> withAccess (Proxy :: Proxy TableNgramsApi) Proxy uid
<$> PathNode <*> apiNgramsTableDoc
......@@ -246,7 +243,6 @@ waitAPI n = do
pure $ "Waited: " <> (cs $ show n)
----------------------------------------
addCorpusWithQuery :: User -> GargServer New.AddWithQuery
addCorpusWithQuery user cid =
serveJobsAPI $
......
src/Gargantext/API/Search.hs
View file @ 1aa7eefa
......@@ -28,7 +28,7 @@ import Gargantext.API.Prelude (GargServer)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Query.Facet
import Gargantext.Database.Action.Search
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataContact)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Prelude
import Servant
......@@ -60,7 +60,7 @@ instance ToSchema SearchDocResults where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sdr_")
data SearchPairedResults =
SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] }
SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataContact Int] }
deriving (Generic)
$(deriveJSON (unPrefix "spr_") ''SearchPairedResults)
......@@ -89,12 +89,12 @@ searchDocs nId (SearchQuery q) o l order =
-----------------------------------------------------------------------
type SearchPairsAPI = Summary ""
:> "list"
:> Capture "list" ListId
:> Capture "annuaire" AnnuaireId
:> SearchAPI SearchPairedResults
searchPairs :: NodeId -> GargServer SearchPairsAPI
searchPairs pId lId (SearchQuery q) o l order =
SearchPairedResults <$> searchInCorpusWithContacts pId lId q o l order
searchPairs pId aId (SearchQuery q) o l order =
SearchPairedResults <$> searchInCorpusWithContacts pId aId q o l order
-----------------------------------------------------------------------
src/Gargantext/Core/Crypto/Hash.hs 0 → 100644
View file @ 1aa7eefa
{-|
Module : Gargantext.Core.Crypto.Hash
Description : Useful Tools near Prelude of the project
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Core.Crypto.Hash
where
import Prelude (String)
import Data.Set (Set)
import Data.List (foldl)
import Data.Text (Text)
import Gargantext.Prelude
import qualified Data.ByteString.Lazy.Char8 as Char
import qualified Data.Digest.Pure.SHA as SHA (sha256, showDigest)
import qualified Data.Set as Set
import qualified Data.Text as Text
--------------------------------------------------------------------------
-- | Use this datatype to keep traceability of hashes
-- TODO use newtype
type Hash = Text
-- | Class to make hashes
class IsHashable a where
hash :: a -> Hash
-- | Main API to hash text
-- using sha256 for now
instance IsHashable Char.ByteString where
hash = Text.pack
. SHA.showDigest
. SHA.sha256
instance {-# OVERLAPPING #-} IsHashable String where
hash = hash . Char.pack
instance IsHashable Text where
hash = hash . Text.unpack
instance IsHashable (Set Hash) where
hash = hash . foldl (<>) "" . Set.toList
instance {-# OVERLAPPABLE #-} IsHashable a => IsHashable [a] where
hash = hash . Set.fromList . map hash
src/Gargantext/Core/Crypto/Pass.hs 0 → 100644
View file @ 1aa7eefa
{-|
Module : Gargantext.Core.Crypto.Pass
Description :
Copyright : (c) CNRS, 2017-Present
License : Public Domain
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
To avoid weak password, just offer an easy way to make "good" one and
let user add his own entropy.
Thanks to
https://zuttobenkyou.wordpress.com/2011/12/23/simple-password-generation-with-haskell/
-}
module Gargantext.Core.Crypto.Pass
where
-- import Data.List (nub)
-- import System.Environment (getArgs)
-- import System.IO (hSetEcho)
import Control.Monad.State
import Crypto.Random (cprgGenerate)
import Crypto.Random.AESCtr
import Data.Binary (decode)
import Prelude
import qualified Data.ByteString.Lazy as B
keysChar, keysNum, keysPunc, keysCharNum, keysAll, keysHex :: String
keysChar = ['a'..'z'] ++ ['A'..'Z']
keysHex = ['a'..'f']
keysNum = ['0'..'9']
keysPunc = "`~!@#$%^&*()-_=+[{]}\\|;:'\",<.>/? "
keysCharNum = keysChar ++ keysNum
keysAll = keysChar ++ keysNum ++ keysPunc
giveKey :: String -> Char -> Int -> Char
giveKey keysCustom c n = extractChar $ case c of
'i' -> (keysNum ++ keysHex)
'j' -> keysNum
'k' -> keysChar
'l' -> keysCharNum
';' -> keysPunc
'h' -> (keysCharNum ++ keysCustom)
'\n' -> ['\n']
_ -> keysAll
where
extractChar xs = xs!!mod n (length xs)
showRandomKey :: Int -> String -> StateT AESRNG IO ()
showRandomKey len keysCustom = handleKey =<< liftIO getChar
where
handleKey key = case key of
'\n' -> liftIO (putChar '\n') >> showRandomKey len keysCustom
'q' -> (liftIO $ putStrLn "\nBye!") >> return ()
_ -> mapM_ f [0..len] >> (liftIO $ putStrLn []) >> showRandomKey len keysCustom
where
f _ = liftIO
. putChar
. giveKey keysCustom key
. (\n -> mod n (length (keysAll ++ keysCustom) - 1))
=<< aesRandomInt
aesRandomInt :: StateT AESRNG IO Int
aesRandomInt = do
aesState <- get
-- aesState <- liftIO makeSystem
-- let aesState = 128
let (bs, aesState') = cprgGenerate 64 aesState
put aesState'
return (decode $ B.fromChunks [bs])
gargPass :: IO (Int, AESRNG)
gargPass = do
-- let as = ["alphanumeric","punctuation"]
-- let as' = filter (\c -> elem c keysAll) . nub $ unwords as
aesState <- makeSystem -- gather entropy from the system to use as the initial seed
--_ <- runStateT (showRandomKey len as') aesState -- enter loop
-- return ()
pass <- runStateT aesRandomInt aesState -- enter loop
pure pass
{-
main :: IO ()
main = do
hSetBuffering stdin NoBuffering -- disable buffering from STDIN
hSetBuffering stdout NoBuffering -- disable buffering from STDOUT
hSetEcho stdin False -- disable terminal echo
as <- getArgs
let as' = filter (\c -> elem c keysAll) . nub $ unwords as
mapM_ putStrLn
[ []
, "poke: 'q' quit"
, " 'j' number"
, " 'k' letter"
, " 'l' alphanumeric"
, " ';' punctuation"
, " 'h' alphanumeric" ++ (if null as' then [] else " + " ++ as')
, " 'i' hexadecimal"
, " 'ENTER' newline"
, " else any"
, []
]
aesState <- makeSystem -- gather entropy from the system to use as the initial seed
_ <- runStateT (showRandomKey as') aesState -- enter loop
return ()
-}
src/Gargantext/Core/Mail.hs 0 → 100644
View file @ 1aa7eefa
{-|
Module : Gargantext.Core.Mail
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Core.Mail
(gargMail)
where
import Data.Maybe
import Network.Mail.SMTP hiding (htmlPart)
import Gargantext.Prelude
import Network.Mail.Mime (plainPart)
-- | TODO add parameters
gargMail :: IO ()
gargMail = sendMail "localhost" mail
where
mail = simpleMail from to cc bcc subject [body]
from = Address (Just "François Rabelais") "francois.rabelais@gargantext.org"
to = [Address (Just "Anoe") "alexandre@localhost"]
cc = []
bcc = []
subject = "email subject"
body = plainPart "email body"
src/Gargantext/Database.hs
View file @ 1aa7eefa
......@@ -16,12 +16,40 @@ Gargantext's database.
module Gargantext.Database ( module Gargantext.Database.Prelude
, module Gargantext.Database.Schema.NodeNode
, insertDB
-- , module Gargantext.Database.Bashql
)
where
import Gargantext.Database.Prelude (connectGargandb)
-- import Gargantext.Database.Bashql
import Gargantext.Prelude
import Gargantext.Database.Prelude -- (connectGargandb)
-- import Gargantext.Database.Schema.Node
-- import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Schema.NodeNode -- (NodeNode(..))
import Gargantext.Database.Query.Table.NodeNode
class InsertDB a where
insertDB :: a -> Cmd err Int
{-
class DeleteDB a where
deleteDB :: a -> Cmd err Int
-}
instance InsertDB [NodeNode] where
insertDB = insertNodeNode
{-
instance InsertDB [Node a] where
insertDB = insertNodes'
instance InsertDB [NodeNodeNgram] where
insertDB = ...
-}
src/Gargantext/Database/Action/Flow.hs
View file @ 1aa7eefa
......@@ -27,6 +27,7 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
( FlowCmdM
, getDataText
, flowDataText
, flow
, flowCorpusFile
, flowCorpus
......@@ -68,7 +69,7 @@ import Gargantext.Database.Action.Flow.Utils (insertDocNgrams)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
import Gargantext.Database.Query.Tree.Root (getOrMkRoot, getOrMk_RootWithCorpus)
import Gargantext.Database.Action.Search (searchInDatabase)
import Gargantext.Database.Action.Search (searchDocInDatabase)
import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Admin.Types.Hyperdata
......@@ -106,11 +107,9 @@ allDataOrigins = map InternalOrigin API.externalAPIs
<> map ExternalOrigin API.externalAPIs
---------------
data DataText = DataOld ![NodeId]
| DataNew ![[HyperdataDocument]]
-- TODO use the split parameter in config file
getDataText :: FlowCmdM env err m
=> DataOrigin
......@@ -126,7 +125,7 @@ getDataText (InternalOrigin _) _la q _li = do
(UserName userMaster)
(Left "")
(Nothing :: Maybe HyperdataCorpus)
ids <- map fst <$> searchInDatabase cId (stemIt q)
ids <- map fst <$> searchDocInDatabase cId (stemIt q)
pure $ DataOld ids
-------------------------------------------------------------------------------
......
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @ 1aa7eefa
......@@ -10,129 +10,176 @@ Portability : POSIX
-}
{-# LANGUAGE QuasiQuotes #-}
-- {-# LANGUAGE Arrows #-}
{-# LANGUAGE Arrows #-}
module Gargantext.Database.Action.Flow.Pairing
(pairing)
-- (pairing)
where
import Control.Lens (_Just, (^.))
import Data.Map (Map, fromList)
import Data.Maybe (catMaybes)
import Data.Text (Text, toLower)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core.Types (TableResult(..))
import Gargantext.Database.Action.Flow.Utils
import Gargantext.Database.Admin.Types.Node (AnnuaireId, CorpusId, ListId{-, DocId, ContactId-})
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
import Gargantext.Database.Query.Table.Node.Children (getAllContacts)
import Data.Map (Map, fromList, fromListWith)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Set (Set)
import Data.Text (Text)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Prelude (GargNoServer)
import Gargantext.Core.Types (TableResult(..), Term)
import Gargantext.Core.Types.Main
import Gargantext.Database
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Hyperdata -- (HyperdataContact(..))
import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, DocId, ContactId, NodeId)
import Gargantext.Database.Prelude (Cmd, runOpaQuery)
import Gargantext.Database.Query.Prelude (leftJoin2, returnA, queryNodeNodeTable)
import Gargantext.Database.Query.Table.Node.Children (getAllContacts)
import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
import Gargantext.Database.Schema.Node
import Gargantext.Prelude hiding (sum)
import Opaleye
import Safe (lastMay)
import qualified Data.Map as DM
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as DT
-- TODO mv this type in Types Main
type Terms = Text
{-
pairing'' :: (CorpusId, CorpusId) -> (DocId -> DocId)
pairing'' = undefined
pairing' :: (CorpusId, AnnuaireId) -> (DocId -> ContactId)
pairing' = undefined
-}
-- | TODO : add paring policy as parameter
pairing :: CorpusId -- (CorpusId, ListId) -- Pair (Either CorpusId AnnuaireId) ListId
-> AnnuaireId -- (AnnuaireId, ListId) -- Pair (Either CorpusId AnnuaireId) ListId
-> ListId
-> Cmd err Int
pairing cId aId lId = do
contacts' <- getAllContacts aId
let contactsMap = pairingPolicyToMap toLower
$ toMaps extractNgramsT (tr_docs contacts')
-- | isPairedWith
-- All NodeAnnuaire paired with a Corpus of NodeId nId:
-- isPairedWith NodeAnnuaire corpusId
isPairedWith :: NodeType -> NodeId -> Cmd err [NodeId]
isPairedWith nt nId = runOpaQuery (selectQuery nt nId)
where
selectQuery :: NodeType -> NodeId -> Query (Column PGInt4)
selectQuery nt' nId' = proc () -> do
(node, node_node) <- queryJoin -< ()
restrict -< (node^.node_typename) .== (pgInt4 $ nodeTypeId nt')
restrict -< (node_node^.nn_node1_id) .== (toNullable $ pgNodeId nId')
returnA -< node^.node_id
queryJoin :: Query (NodeRead, NodeNodeReadNull)
queryJoin = leftJoin2 queryNodeTable queryNodeNodeTable cond
where
cond (node, node_node) = node^.node_id .== node_node^. nn_node2_id
ngramsMap' <- getNgramsTindexed cId Authors
let ngramsMap = pairingPolicyToMap lastName ngramsMap'
let indexedNgrams = pairMaps contactsMap ngramsMap
insertDocNgrams lId indexedNgrams
lastName :: Terms -> Terms
lastName texte = DT.toLower
$ maybe texte (\x -> if DT.length x > 3 then x else texte) (lastName' texte)
-----------------------------------------------------------------------
pairing :: AnnuaireId -> CorpusId -> ListId -> GargNoServer Int
pairing a c l = do
dataPaired <- dataPairing a (c,l,Authors) takeName takeName
insertDB $ prepareInsert dataPaired
dataPairing :: AnnuaireId
-> (CorpusId, ListId, NgramsType)
-> (ContactName -> Projected)
-> (DocAuthor -> Projected)
-> GargNoServer (Map ContactId (Set DocId))
dataPairing aId (cId, lId, ngt) fc fa = do
mc <- getNgramsContactId aId
md <- getNgramsDocId cId lId ngt
printDebug "ngramsContactId" mc
printDebug "ngramsDocId" md
let
from = projectionFrom (Set.fromList $ Map.keys mc) fc
to = projectionTo (Set.fromList $ Map.keys md) fa
pure $ fusion mc $ align from to md
prepareInsert :: Map ContactId (Set DocId) -> [NodeNode]
prepareInsert m = map (\(n1,n2) -> NodeNode n1 n2 Nothing Nothing)
$ List.concat
$ map (\(contactId, setDocIds)
-> map (\setDocId
-> (contactId, setDocId)
) $ Set.toList setDocIds
)
$ Map.toList m
------------------------------------------------------------------------
type ContactName = Text
type DocAuthor = Text
type Projected = Text
projectionFrom :: Set ContactName -> (ContactName -> Projected) -> Map ContactName Projected
projectionFrom ss f = fromList $ map (\s -> (s, f s)) (Set.toList ss)
projectionTo :: Set DocAuthor -> (DocAuthor -> Projected) -> Map Projected (Set DocAuthor)
projectionTo ss f = fromListWith (<>) $ map (\s -> (f s, Set.singleton s)) (Set.toList ss)
------------------------------------------------------------------------
takeName :: Term -> Term
takeName texte = DT.toLower texte'
where
texte' = maybe texte (\x -> if DT.length x > 3 then x else texte)
(lastName' texte)
lastName' = lastMay . DT.splitOn " "
-- TODO: this method is dangerous (maybe equalities of the result are
-- not taken into account emergency demo plan...)
pairingPolicyToMap :: (Terms -> Terms)
-> Map (NgramsT Ngrams) a
-> Map (NgramsT Ngrams) a
pairingPolicyToMap f = DM.mapKeys (pairingPolicy f)
pairingPolicy :: (Terms -> Terms)
-> NgramsT Ngrams
-> NgramsT Ngrams
pairingPolicy f (NgramsT nt (Ngrams ng _)) = (NgramsT nt (Ngrams (f ng) 1))
-- | TODO : use Occurrences in place of Int
extractNgramsT :: HyperdataContact
-> Map (NgramsT Ngrams) Int
extractNgramsT contact = fromList [(NgramsT Authors a' , 1)| a' <- authors ]
------------------------------------------------------------------------
align :: Map ContactName Projected
-> Map Projected (Set DocAuthor)
-> Map DocAuthor (Set DocId)
-> Map ContactName (Set DocId)
align mc ma md = fromListWith (<>)
$ map (\c -> (c, getProjection md $ testProjection c mc ma))
$ Map.keys mc
where
getProjection :: Map DocAuthor (Set DocId) -> Set DocAuthor -> Set DocId
getProjection ma' sa' =
if Set.null sa'
then Set.empty
else Set.unions $ sets ma' sa'
where
authors = map text2ngrams
$ catMaybes [ contact^.(hc_who . _Just . cw_lastName) ]
pairMaps :: Map (NgramsT Ngrams) a
-> Map (NgramsT Ngrams) NgramsId
-> Map NgramsIndexed (Map NgramsType a)
pairMaps m1 m2 =
DM.fromList
[ (NgramsIndexed ng nId, DM.singleton nt n2i)
| (k@(NgramsT nt ng),n2i) <- DM.toList m1
, Just nId <- [DM.lookup k m2]
sets ma'' sa'' = Set.map (\s -> lookup s ma'') sa''
lookup s' ma''= fromMaybe Set.empty (Map.lookup s' ma'')
testProjection :: ContactName
-> Map ContactName Projected
-> Map Projected (Set DocAuthor)
-> Set DocAuthor
testProjection cn' mc' ma' = case Map.lookup cn' mc' of
Nothing -> Set.empty
Just c -> case Map.lookup c ma' of
Nothing -> Set.empty
Just a -> a
fusion :: Map ContactName (Set ContactId)
-> Map ContactName (Set DocId)
-> Map ContactId (Set DocId)
fusion mc md = Map.fromListWith (<>)
$ catMaybes
$ [ (,) <$> Just cId <*> Map.lookup cn md
| (cn, setContactId) <- Map.toList mc
, cId <- Set.toList setContactId
]
------------------------------------------------------------------------
-----------------------------------------------------------------------
getNgramsTindexed :: CorpusId
-> NgramsType
-> Cmd err (Map (NgramsT Ngrams) NgramsId)
getNgramsTindexed corpusId ngramsType' = fromList
<$> map (\(ngramsId',t,n) -> (NgramsT ngramsType' (Ngrams t n),ngramsId'))
<$> selectNgramsTindexed corpusId ngramsType'
where
selectNgramsTindexed :: CorpusId
getNgramsContactId :: AnnuaireId
-> Cmd err (Map ContactName (Set NodeId))
getNgramsContactId aId = do
contacts <- getAllContacts aId
pure $ fromListWith (<>)
$ catMaybes
$ map (\contact -> (,) <$> contact^.(node_hyperdata . hc_who . _Just . cw_lastName)
<*> Just ( Set.singleton (contact^.node_id))
) (tr_docs contacts)
getNgramsDocId :: CorpusId
-> ListId
-> NgramsType
-> Cmd err [(NgramsId, Terms, Int)]
selectNgramsTindexed corpusId' ngramsType'' = runPGSQuery selectQuery (corpusId', ngramsTypeId ngramsType'')
where
selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
JOIN node_node_ngrams occ ON occ.ngrams_id = n.id
-- JOIN node_node_ngrams2 occ ON occ.ngrams_id = n.id
JOIN nodes_nodes nn ON nn.node2_id = occ.node2_id
WHERE nn.node1_id = ?
AND occ.ngrams_type = ?
AND occ.node2_id = nn.node2_id
GROUP BY n.id;
|]
{- | TODO more typed SQL queries
selectNgramsTindexed :: CorpusId -> NgramsType -> Query NgramsRead
selectNgramsTindexed corpusId ngramsType = proc () -> do
nodeNode <- queryNodeNodeTable -< ()
nodeNgrams <- queryNodesNgramsTable -< ()
ngrams <- queryNgramsTable -< ()
restrict -< node1_id nodeNode .== pgInt4 corpusId
restrict -< node2_id nodeNode .== node_id nodeNgrams
restrict -< ngrams_id ngrams .== node_ngrams nodeNgrams
result <- aggregate groupBy (ngrams_id ngrams)
returnA -< result
--}
-> GargNoServer (Map DocAuthor (Set NodeId))
getNgramsDocId cId lId nt = do
repo <- getRepo
lIds <- selectNodesWithUsername NodeList userMaster
let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
groupNodesByNgrams ngs
<$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
src/Gargantext/Database/Action/Learn.hs
View file @ 1aa7eefa
......@@ -34,9 +34,9 @@ data FavOrTrash = IsFav | IsTrash
moreLike :: CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
-> FavOrTrash -> Cmd err [FacetDoc]
moreLike cId o l order ft = do
moreLike cId o _l order ft = do
priors <- getPriors ft cId
moreLikeWith cId o l order ft priors
moreLikeWith cId o (Just 3) order ft priors
---------------------------------------------------------------------------
getPriors :: FavOrTrash -> CorpusId -> Cmd err (Events Bool)
......
src/Gargantext/Database/Action/Node.hs
View file @ 1aa7eefa
......@@ -28,7 +28,7 @@ import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Prelude
import Gargantext.Prelude.Utils (hash)
import Gargantext.Core.Crypto.Hash (hash)
import Gargantext.Database.Prelude
import Control.Lens (view)
import Gargantext.Config (GargConfig(..))
......
src/Gargantext/Database/Action/Search.hs
View file @ 1aa7eefa
......@@ -15,41 +15,39 @@ module Gargantext.Database.Action.Search where
import Control.Arrow (returnA)
import Control.Lens ((^.))
import Data.Aeson
import Data.List (intersperse, take, drop)
import Data.Map.Strict hiding (map, drop, take)
import Data.List (intersperse)
import Data.Maybe
import Data.String (IsString(..))
import Data.Text (Text, words, unpack, intercalate)
import Data.Time (UTCTime)
import Database.PostgreSQL.Simple (Query)
import Database.PostgreSQL.Simple.ToField
import Opaleye hiding (Query, Order)
import qualified Opaleye as O hiding (Order)
import Gargantext.Core.Types
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..), HyperdataContact(..))
import Gargantext.Database.Admin.Types.Node (NodeType(..))
import Gargantext.Database.Prelude (Cmd, runPGSQuery, runOpaQuery, runCountOpaQuery)
import Gargantext.Database.Query.Facet
import Gargantext.Database.Query.Join (leftJoin6)
import Gargantext.Database.Query.Filter
import Gargantext.Database.Query.Join (leftJoin5)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.NodeNode
import Gargantext.Database.Query.Table.NodeNodeNgrams
import Gargantext.Database.Query.Table.Ngrams
import Gargantext.Database.Prelude (Cmd, runPGSQuery, runOpaQuery, runCountOpaQuery)
import Gargantext.Database.Schema.Node
import Gargantext.Prelude
import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
import Opaleye hiding (Query, Order)
import Data.Profunctor.Product (p4)
import qualified Opaleye as O hiding (Order)
------------------------------------------------------------------------
searchInDatabase :: ParentId
searchDocInDatabase :: ParentId
-> Text
-> Cmd err [(NodeId, HyperdataDocument)]
searchInDatabase p t = runOpaQuery (queryInDatabase p t)
searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
where
-- | Global search query where ParentId is Master Node Corpus Id
queryInDatabase :: ParentId -> Text -> O.Query (Column PGInt4, Column PGJsonb)
queryInDatabase _ q = proc () -> do
queryDocInDatabase :: ParentId -> Text -> O.Query (Column PGInt4, Column PGJsonb)
queryDocInDatabase _ q = proc () -> do
row <- queryNodeSearchTable -< ()
restrict -< (_ns_search row) @@ (pgTSQuery (unpack q))
restrict -< (_ns_typename row) .== (pgInt4 $ nodeTypeId NodeDocument)
......@@ -105,131 +103,134 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
cond (n, nn) = nn^.nn_node2_id .== _ns_id n
------------------------------------------------------------------------
type AuthorName = Text
-- | TODO Optim: Offset and Limit in the Query
-- TODO-SECURITY check
searchInCorpusWithContacts
:: CorpusId
-> ListId
-> [Text]
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
searchInCorpusWithContacts cId lId q o l order =
take (maybe 10 identity l)
<$> drop (maybe 0 identity o)
<$> map (\((i,u,h,s), ps) -> FacetPaired i u h s ps)
<$> toList <$> fromListWith (<>)
<$> map (\(FacetPaired i u h s (p1,p2)) -> ( (i,u,h,s)
, catMaybes [Pair <$> p1 <*> p2]
)
)
<$> searchInCorpusWithContacts' cId lId q o l order
-- TODO-SECURITY check
searchInCorpusWithContacts'
:: CorpusId
-> ListId
-> AnnuaireId
-> [Text]
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Maybe Int, Maybe Text))]
searchInCorpusWithContacts' cId lId q o l order =
runOpaQuery $ queryInCorpusWithContacts cId lId o l order
-> Cmd err [FacetPaired Int UTCTime HyperdataContact Int]
searchInCorpusWithContacts cId aId q o l _order =
runOpaQuery $ limit' l
$ offset' o
$ orderBy ( desc _fp_score)
$ group cId aId
$ intercalate " | "
$ map stemIt q
queryInCorpusWithContacts
-- TODO group by
selectContactViaDoc
:: CorpusId
-> ListId
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> AnnuaireId
-> Text
-> O.Query FacetPairedRead
queryInCorpusWithContacts cId _lId _ _ _ q = proc () -> do
(n, (nn, (_nng, (ngrams', (_, contacts))))) <- joinInCorpusWithContacts -< ()
restrict -< (n^.ns_search) @@ (pgTSQuery $ unpack q )
restrict -< (n^.ns_typename) .== (pgInt4 $ nodeTypeId NodeDocument)
-- restrict -< (nng^.nnng_node1_id) .== (toNullable $ pgNodeId lId)
restrict -< (nn^.nn_node1_id) .== (toNullable $ pgNodeId cId)
-- -- restrict -< (nng_listType nng) .== (toNullable $ pgNgramsType Authors)
-- restrict -< (contacts^.node_typename) .== (toNullable $ pgInt4 $ nodeTypeId NodeContact)
-- -- let contact_id = ifThenElse (isNull $ _node_id contacts) (toNullable $ pgInt4 0) (_node_id contacts)
returnA -< FacetPaired (n^.ns_id)
(n^.ns_date)
(n^.ns_hyperdata)
(pgInt4 0)
(contacts^.node_id, ngrams'^.ngrams_terms)
-> Select FacetPairedReadNull
selectContactViaDoc cId aId q = proc () -> do
(doc, (corpus_doc, (_contact_doc, (annuaire_contact, contact)))) <- queryContactViaDoc -< ()
restrict -< (doc^.ns_search) @@ (pgTSQuery $ unpack q )
restrict -< (doc^.ns_typename) .== (pgInt4 $ nodeTypeId NodeDocument)
restrict -< (corpus_doc^.nn_node1_id) .== (toNullable $ pgNodeId cId)
restrict -< (annuaire_contact^.nn_node1_id) .== (toNullable $ pgNodeId aId)
restrict -< (contact^.node_typename) .== (toNullable $ pgInt4 $ nodeTypeId NodeContact)
returnA -< FacetPaired (contact^.node_id)
(contact^.node_date)
(contact^.node_hyperdata)
(toNullable $ pgInt4 1)
selectContactViaDoc'
:: CorpusId
-> AnnuaireId
-> Text
-> QueryArr ()
( Column (Nullable PGInt4)
, Column (Nullable PGTimestamptz)
, Column (Nullable PGJsonb)
, Column (Nullable PGInt4)
)
selectContactViaDoc' cId aId q = proc () -> do
(doc, (corpus_doc, (_contact_doc, (annuaire_contact, contact)))) <- queryContactViaDoc -< ()
restrict -< (doc^.ns_search) @@ (pgTSQuery $ unpack q )
restrict -< (doc^.ns_typename) .== (pgInt4 $ nodeTypeId NodeDocument)
restrict -< (corpus_doc^.nn_node1_id) .== (toNullable $ pgNodeId cId)
restrict -< (annuaire_contact^.nn_node1_id) .== (toNullable $ pgNodeId aId)
restrict -< (contact^.node_typename) .== (toNullable $ pgInt4 $ nodeTypeId NodeContact)
returnA -< ( contact^.node_id
, contact^.node_date
, contact^.node_hyperdata
, toNullable $ pgInt4 1
)
joinInCorpusWithContacts :: O.Query ( NodeSearchRead
group :: NodeId
-> NodeId
-> Text
-> Select FacetPairedReadNull
group cId aId q = proc () -> do
(a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
(selectContactViaDoc' cId aId q) -< ()
returnA -< FacetPaired a b c d
queryContactViaDoc :: O.Query ( NodeSearchRead
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, ( NodeNodeNgramsReadNull
, ( NgramsReadNull
, ( NodeNodeNgramsReadNull
, NodeReadNull
)
)
)
)
)
joinInCorpusWithContacts =
leftJoin6
queryContactViaDoc =
leftJoin5
queryNodeTable
queryNodeNodeNgramsTable
queryNgramsTable
queryNodeNodeNgramsTable
queryNodeNodeTable
queryNodeNodeTable
queryNodeNodeTable
queryNodeSearchTable
cond12
cond23
cond34
cond45
cond56
where
cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
cond12 (nnng, n2) = n2^.node_id .== nnng^.nnng_node1_id
cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
cond23 (ng2, (nnng2, _)) = nnng2^.nnng_ngrams_id .== ng2^.ngrams_id
cond12 :: (NodeNodeRead, NodeRead) -> Column PGBool
cond12 (annuaire_contact, contact) = contact^.node_id .== annuaire_contact^.nn_node2_id
cond34 :: ( NodeNodeNgramsRead
, ( NgramsRead
, ( NodeNodeNgramsReadNull
cond23 :: ( NodeNodeRead
, ( NodeNodeRead
, NodeReadNull
)
)
) -> Column PGBool
cond34 (nng, (ng, (_,_))) = ng^.ngrams_id .== nng^.nnng_ngrams_id
cond23 (contact_doc, (annuaire_contact, _)) = contact_doc^.nn_node1_id .== annuaire_contact^.nn_node2_id
cond45 :: ( NodeNodeRead
, ( NodeNodeNgramsRead
, ( NgramsReadNull
, ( NodeNodeNgramsReadNull
cond34 :: ( NodeNodeRead
, ( NodeNodeRead
, ( NodeNodeReadNull
, NodeReadNull
)
)
)
) -> Column PGBool
cond45 (nn, (nng, (_,(_,_)))) = nng^.nnng_node1_id .== nn^.nn_node2_id
cond34 (corpus_doc, (contact_doc, (_,_))) = corpus_doc^.nn_node2_id .== contact_doc^.nn_node2_id
cond56 :: ( NodeSearchRead
cond45 :: ( NodeSearchRead
, ( NodeNodeRead
, ( NodeNodeNgramsReadNull
, ( NgramsReadNull
, ( NodeNodeNgramsReadNull
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, NodeReadNull
)
)
)
)
) -> Column PGBool
cond56 (n, (nn, (_,(_,(_,_))))) = _ns_id n .== nn^.nn_node2_id
cond45 (doc, (corpus_doc, (_,(_,_)))) = doc^.ns_id .== corpus_doc^.nn_node2_id
------------------------------------------------------------------------
newtype TSQuery = UnsafeTSQuery [Text]
......
src/Gargantext/Database/Action/Share.hs
View file @ 1aa7eefa
......@@ -14,6 +14,7 @@ module Gargantext.Database.Action.Share
where
import Control.Lens (view)
import Gargantext.Database
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Flow.Utils (getUserId)
import Gargantext.Database.Admin.Config (hasNodeType, isInNodeTypes)
......@@ -23,7 +24,7 @@ import Gargantext.Database.Admin.Types.Node -- (NodeType(..))
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Query.Table.Node (getNode, getNodesWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError, errorWith)
import Gargantext.Database.Query.Table.NodeNode (insertNodeNode, deleteNodeNode)
import Gargantext.Database.Query.Table.NodeNode (deleteNodeNode)
import Gargantext.Database.Query.Tree.Root (getRootId)
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.NodeNode (NodeNodePoly(..))
......@@ -45,7 +46,7 @@ data ShareNodeWith = ShareNodeWith_User { snwu_nodetype :: NodeType
shareNodeWith :: HasNodeError err
=> ShareNodeWith
-> NodeId
-> Cmd err Int64
-> Cmd err Int
shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
nodeToCheck <- getNode n
userIdCheck <- getUserId u
......@@ -56,7 +57,7 @@ shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
then errorWith "[G.D.A.S.shareNodeWith] Can share to others only"
else do
folderSharedId <- getFolderId u NodeFolderShared
insertNodeNode [NodeNode folderSharedId n Nothing Nothing]
insertDB ([NodeNode folderSharedId n Nothing Nothing]:: [NodeNode])
shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
nodeToCheck <- getNode n
......@@ -66,7 +67,7 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
else do
folderToCheck <- getNode nId
if hasNodeType folderToCheck NodeFolderPublic
then insertNodeNode [NodeNode nId n Nothing Nothing]
then insertDB ([NodeNode nId n Nothing Nothing] :: [NodeNode])
else errorWith "[G.D.A.S.shareNodeWith] Can share NodeWith NodeFolderPublic only"
shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType"
......
src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs
View file @ 1aa7eefa
......@@ -54,6 +54,15 @@ defaultHyperdataContact = HyperdataContact (Just "bdd")
(Just "DO NOT expose this")
(Just "DO NOT expose this")
hyperdataContact :: FirstName -> LastName -> HyperdataContact
hyperdataContact fn ln = HyperdataContact Nothing
(Just (contactWho fn ln))
[]
Nothing
Nothing
Nothing
Nothing
Nothing
-- TOD0 contact metadata (Type is too flat)
data ContactMetaData =
......@@ -78,12 +87,20 @@ data ContactWho =
, _cw_freetags :: [Text]
} deriving (Eq, Show, Generic)
type FirstName = Text
type LastName = Text
defaultContactWho :: ContactWho
defaultContactWho = ContactWho (Just "123123")
(Just "First Name")
(Just "Last Name")
["keyword A"]
["freetag A"]
defaultContactWho = contactWho "Pierre" "Dupont"
contactWho :: FirstName -> LastName -> ContactWho
contactWho fn ln = ContactWho Nothing
(Just fn)
(Just ln)
[]
[]
data ContactWhere =
ContactWhere { _cw_organization :: [Text]
......@@ -150,6 +167,12 @@ instance FromField HyperdataContact where
instance QueryRunnerColumnDefault PGJsonb HyperdataContact where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault (Nullable PGJsonb) HyperdataContact where
queryRunnerColumnDefault = fieldQueryRunnerColumn
-- | All lenses
makeLenses ''ContactWho
makeLenses ''ContactWhere
......
src/Gargantext/Database/Admin/Types/Hyperdata/Prelude.hs
View file @ 1aa7eefa
......@@ -48,7 +48,7 @@ import GHC.Generics (Generic)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Prelude (fromField')
import Gargantext.Prelude
import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn, Nullable)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
......
src/Gargantext/Database/Admin/Types/Node.hs
View file @ 1aa7eefa
......@@ -157,6 +157,7 @@ instance Arbitrary NodeId where
type ParentId = NodeId
type CorpusId = NodeId
type CommunityId = NodeId
type ListId = NodeId
type DocumentId = NodeId
type DocId = NodeId
......@@ -241,6 +242,8 @@ data NodeType = NodeUser
| NodeFolderPublic
| NodeFolder
-- | NodeAnalysis | NodeCommunity
| NodeCorpus | NodeCorpusV3 | NodeTexts | NodeDocument
| NodeAnnuaire | NodeContact
| NodeGraph | NodePhylo
......@@ -336,4 +339,7 @@ instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance (QueryRunnerColumnDefault (Nullable O.PGTimestamptz) UTCTime)
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
src/Gargantext/Database/Prelude.hs
View file @ 1aa7eefa
......@@ -45,7 +45,6 @@ import qualified Data.List as DL
import qualified Database.PostgreSQL.Simple as PGS
-------------------------------------------------------
class HasConnectionPool env where
connPool :: Getter env (Pool Connection)
......
src/Gargantext/Database/Query/Facet.hs
View file @ 1aa7eefa
......@@ -29,6 +29,8 @@ module Gargantext.Database.Query.Facet
, FacetDocRead
, FacetPaired(..)
, FacetPairedRead
, FacetPairedReadNull
, FacetPairedReadNullAgg
, OrderBy(..)
)
where
......@@ -111,44 +113,61 @@ instance (Typeable i, Typeable l, ToSchema i, ToSchema l) => ToSchema (Pair i l)
instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
arbitrary = Pair <$> arbitrary <*> arbitrary
data FacetPaired id date hyperdata score pair =
data FacetPaired id date hyperdata score =
FacetPaired {_fp_id :: id
,_fp_date :: date
,_fp_hyperdata :: hyperdata
,_fp_score :: score
,_fp_pair :: pair
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_fp_") ''FacetPaired)
$(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
instance ( ToSchema id
, ToSchema date
, ToSchema hyperdata
, ToSchema score
, ToSchema pair
, Typeable id
, Typeable date
, Typeable hyperdata
, Typeable score
, Typeable pair
) => ToSchema (FacetPaired id date hyperdata score pair) where
) => ToSchema (FacetPaired id date hyperdata score) where
declareNamedSchema = wellNamedSchema "_fp_"
instance ( Arbitrary id
, Arbitrary date
, Arbitrary hyperdata
, Arbitrary score
, Arbitrary pair
) => Arbitrary (FacetPaired id date hyperdata score pair) where
arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
) => Arbitrary (FacetPaired id date hyperdata score) where
arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
type FacetPairedRead = FacetPaired (Column PGInt4 )
(Column PGTimestamptz)
(Column PGJsonb )
(Column PGInt4 )
( Column (Nullable PGInt4)
, Column (Nullable PGText)
type FacetPairedReadNull = FacetPaired (Column (Nullable PGInt4) )
(Column (Nullable PGTimestamptz))
(Column (Nullable PGJsonb) )
(Column (Nullable PGInt4) )
type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable PGInt4) )
(Column (Nullable PGInt4) )
)
(Aggregator (Column (Nullable PGTimestamptz))
(Column (Nullable PGTimestamptz))
)
(Aggregator (Column (Nullable PGJsonb) )
(Column (Nullable PGJsonb) )
)
(Aggregator (Column (Nullable PGInt4) )
(Column (Nullable PGInt4) )
)
-- | JSON instance
$(deriveJSON (unPrefix "facetDoc_") ''Facet)
......
src/Gargantext/Database/Query/Join.hs
View file @ 1aa7eefa
......@@ -22,7 +22,15 @@ Multiple Join functions with Opaleye.
------------------------------------------------------------------------
module Gargantext.Database.Query.Join
module Gargantext.Database.Query.Join ( leftJoin2
, leftJoin3
, leftJoin4
, leftJoin5
, leftJoin6
, leftJoin7
, leftJoin8
, leftJoin9
)
where
import Control.Applicative ((<*>))
......@@ -33,17 +41,24 @@ import Opaleye
import Opaleye.Internal.Join (NullMaker(..))
import qualified Opaleye.Internal.Unpackspec()
--leftJoin3 :: Query columnsL1 -> Query columnsR -> Query columnsL
-- -> ((columnsL1, columnsR) -> Column PGBool)
-- -> ((columnsL, (columnsL1, nullableColumnsR1)) -> Column PGBool)
-- -> Query (columnsL, nullableColumnsR)
--leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
join3 :: Query columnsA -> Query columnsB -> Query columnsC
------------------------------------------------------------------------
leftJoin2 :: (Default Unpackspec fieldsL fieldsL,
Default Unpackspec fieldsR fieldsR,
Default NullMaker fieldsR nullableFieldsR) =>
Select fieldsL
-> Select fieldsR
-> ((fieldsL, fieldsR) -> Column PGBool)
-> Select (fieldsL, nullableFieldsR)
leftJoin2 = leftJoin
------------------------------------------------------------------------
-- | LeftJoin3 in two ways to write it
_leftJoin3 :: Query columnsA -> Query columnsB -> Query columnsC
-> ((columnsA, columnsB, columnsC) -> Column PGBool)
-> Query (columnsA, columnsB, columnsC)
join3 q1 q2 q3 cond = ((,,) <$> q1 <*> q2 <*> q3) >>> keepWhen cond
_leftJoin3 q1 q2 q3 cond = ((,,) <$> q1 <*> q2 <*> q3) >>> keepWhen cond
------------------------------------------------------------------------
leftJoin3
:: (Default Unpackspec fieldsL1 fieldsL1,
Default Unpackspec fieldsL2 fieldsL2,
......
src/Gargantext/Database/Query/Prelude.hs 0 → 100644
View file @ 1aa7eefa
{-|
Module : Gargantext.Database.Query.Prelude
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
------------------------------------------------------------------------
module Gargantext.Database.Query.Prelude
( module Gargantext.Database.Query.Join
, module Gargantext.Database.Query.Table.Node
, module Gargantext.Database.Query.Table.NodeNode
, module Control.Arrow
)
where
import Control.Arrow (returnA)
import Gargantext.Database.Query.Join
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.NodeNode
src/Gargantext/Database/Query/Table/Ngrams.hs
View file @ 1aa7eefa
......@@ -59,7 +59,7 @@ selectNgramsByDoc lIds dId nt = runOpaQuery (query lIds dId nt)
_postNgrams :: CorpusId -> DocId -> [Text] -> Cmd err Int
_postNgrams = undefined
_dbGetNgramsDb :: Cmd err [NgramsDb]
_dbGetNgramsDb :: Cmd err [NgramsDB]
_dbGetNgramsDb = runOpaQuery queryNgramsTable
......
src/Gargantext/Database/Query/Table/Node.hs
View file @ 1aa7eefa
......@@ -190,6 +190,23 @@ node nodeType name hyperData parentId userId =
insertNodes :: [NodeWrite] -> Cmd err Int64
insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
{-
insertNodes' :: [Node a] -> Cmd err Int64
insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
$ Insert nodeTable ns' rCount Nothing
where
ns' :: [NodeWrite]
ns' = map (\(Node i t u p n d h)
-> Node (pgNodeId <$> i)
(pgInt4 $ nodeTypeId t)
(pgInt4 u)
(pgNodeId <$> p)
(pgStrictText n)
(pgUTCTime <$> d)
(pgJSONB $ cs $ encode h)
) ns
-}
insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
insertNodesR ns = mkCmd $ \conn ->
runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
......
src/Gargantext/Database/Query/Table/Node/Children.hs
View file @ 1aa7eefa
......@@ -30,10 +30,13 @@ import Gargantext.Database.Schema.Node
import Opaleye
import Protolude
-- TODO getAllTableDocuments
getAllDocuments :: ParentId -> Cmd err (TableResult (Node HyperdataDocument))
getAllDocuments pId = getAllChildren pId (Proxy :: Proxy HyperdataDocument)
(Just NodeDocument)
-- TODO getAllTableContacts
getAllContacts :: ParentId -> Cmd err (TableResult (Node HyperdataContact))
getAllContacts pId = getAllChildren pId (Proxy :: Proxy HyperdataContact)
(Just NodeContact)
......
src/Gargantext/Database/Query/Table/Node/Document/Insert.hs
View file @ 1aa7eefa
......@@ -72,7 +72,7 @@ import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
import Gargantext.Prelude
import Gargantext.Prelude.Utils (hash)
import Gargantext.Core.Crypto.Hash (hash)
import qualified Data.Text as DT (pack, concat, take)
-- TODO : the import of Document constructor below does not work
......
src/Gargantext/Database/Query/Table/NodeNode.hs
View file @ 1aa7eefa
......@@ -71,9 +71,33 @@ getNodeNode n = runOpaQuery (selectNodeNode $ pgNodeId n)
returnA -< ns
------------------------------------------------------------------------
insertNodeNode :: [NodeNode] -> Cmd err Int64
insertNodeNode ns = mkCmd $ \conn -> runInsert_ conn
$ Insert nodeNodeTable ns' rCount Nothing
-- TODO (refactor with Children)
{-
getNodeNodeWith :: NodeId -> proxy a -> Maybe NodeType -> Cmd err [a]
getNodeNodeWith pId _ maybeNodeType = runOpaQuery query
where
query = selectChildren pId maybeNodeType
selectChildren :: ParentId
-> Maybe NodeType
-> Query NodeRead
selectChildren parentId maybeNodeType = proc () -> do
row@(Node nId typeName _ parent_id _ _ _) <- queryNodeTable -< ()
(NodeNode _ n1id n2id _ _) <- queryNodeNodeTable -< ()
let nodeType = maybe 0 nodeTypeId maybeNodeType
restrict -< typeName .== pgInt4 nodeType
restrict -< (.||) (parent_id .== (pgNodeId parentId))
( (.&&) (n1id .== pgNodeId parentId)
(n2id .== nId))
returnA -< row
-}
------------------------------------------------------------------------
insertNodeNode :: [NodeNode] -> Cmd err Int
insertNodeNode ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
$ Insert nodeNodeTable ns' rCount (Just DoNothing))
where
ns' :: [NodeNodeWrite]
ns' = map (\(NodeNode n1 n2 x y)
......@@ -83,6 +107,8 @@ insertNodeNode ns = mkCmd $ \conn -> runInsert_ conn
(pgInt4 <$> y)
) ns
------------------------------------------------------------------------
type Node1_Id = NodeId
type Node2_Id = NodeId
......
src/Gargantext/Database/Schema/Ngrams.hs
View file @ 1aa7eefa
......@@ -42,7 +42,7 @@ type NgramsId = Int
type NgramsTerms = Text
type Size = Int
data NgramsPoly id terms n = NgramsDb { _ngrams_id :: !id
data NgramsPoly id terms n = NgramsDB { _ngrams_id :: !id
, _ngrams_terms :: !terms
, _ngrams_n :: !n
} deriving (Show)
......@@ -59,14 +59,14 @@ type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
(Column (Nullable PGText))
(Column (Nullable PGInt4))
type NgramsDb = NgramsPoly Int Text Int
type NgramsDB = NgramsPoly Int Text Int
$(makeAdaptorAndInstance "pNgramsDb" ''NgramsPoly)
makeLenses ''NgramsPoly
ngramsTable :: Table NgramsWrite NgramsRead
ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { _ngrams_id = optional "id"
ngramsTable = Table "ngrams" (pNgramsDb NgramsDB { _ngrams_id = optional "id"
, _ngrams_terms = required "terms"
, _ngrams_n = required "n"
}
......
src/Gargantext/Database/Schema/Node.hs
View file @ 1aa7eefa
......@@ -25,7 +25,6 @@ import Prelude hiding (null, id, map, sum)
------------------------------------------------------------------------
-- Main polymorphic Node definition
data NodePoly id
typename
userId
......@@ -53,7 +52,6 @@ $(makeLenses ''NodePoly)
$(makeAdaptorAndInstance "pNode" ''NodePoly)
$(makeLensesWith abbreviatedFields ''NodePoly)
------------------------------------------------------------------------
nodeTable :: Table NodeWrite NodeRead
nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
, _node_typename = required "typename"
......
src/Gargantext/Database/Schema/NodeNode.hs
View file @ 1aa7eefa
......@@ -54,7 +54,9 @@ $(makeAdaptorAndInstance "pNodeNode" ''NodeNodePoly)
makeLenses ''NodeNodePoly
nodeNodeTable :: Table NodeNodeWrite NodeNodeRead
nodeNodeTable = Table "nodes_nodes" (pNodeNode
nodeNodeTable =
Table "nodes_nodes"
( pNodeNode
NodeNode { _nn_node1_id = required "node1_id"
, _nn_node2_id = required "node2_id"
, _nn_score = optional "score"
......@@ -62,8 +64,6 @@ nodeNodeTable = Table "nodes_nodes" (pNodeNode
}
)
instance QueryRunnerColumnDefault (Nullable PGInt4) Int where
queryRunnerColumnDefault = fieldQueryRunnerColumn
......
src/Gargantext/Database/Schema/Prelude.hs
View file @ 1aa7eefa
......@@ -37,7 +37,7 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Data.Swagger hiding (required, in_)
import GHC.Generics (Generic)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Opaleye hiding (FromField)
import Opaleye hiding (FromField, readOnly)
import Opaleye.Internal.QueryArr (Query)
import Test.QuickCheck.Arbitrary
......
src/Gargantext/Prelude.hs
View file @ 1aa7eefa
......@@ -292,9 +292,6 @@ deviation = sqrt . variance
movingAverage :: (Eq b, Fractional b) => Int -> [b] -> [b]
movingAverage steps xs = map mean $ chunkAlong steps 1 xs
ma :: [Double] -> [Double]
ma = movingAverage 3
-----------------------------------------------------------------------
-----------------------------------------------------------------------
--- Map in Map = Map2
......
src/Gargantext/Prelude/Utils.hs
View file @ 1aa7eefa
......@@ -14,9 +14,6 @@ Portability : POSIX
module Gargantext.Prelude.Utils
where
import Prelude (String)
import Data.Set (Set)
import Data.List (foldl)
import Control.Lens (view)
import Control.Monad.Random.Class (MonadRandom)
import Control.Monad.Reader (MonadReader)
......@@ -26,11 +23,9 @@ import GHC.IO (FilePath)
import Gargantext.API.Admin.Settings
import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
import Gargantext.Prelude
import Gargantext.Core.Crypto.Hash
import System.Directory (createDirectoryIfMissing)
import System.Random (newStdGen)
import qualified Data.ByteString.Lazy.Char8 as Char
import qualified Data.Digest.Pure.SHA as SHA (sha256, showDigest)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified System.Random.Shuffle as SRS
......@@ -38,34 +33,6 @@ import qualified System.Random.Shuffle as SRS
shuffle :: MonadRandom m => [a] -> m [a]
shuffle ns = SRS.shuffleM ns
--------------------------------------------------------------------------
-- | Use this datatype to keep traceability of hashes
-- TODO use newtype
type Hash = Text
-- | Class to make hashes
class IsHashable a where
hash :: a -> Hash
-- | Main API to hash text
-- using sha256 for now
instance IsHashable Char.ByteString where
hash = Text.pack
. SHA.showDigest
. SHA.sha256
instance {-# OVERLAPPING #-} IsHashable String where
hash = hash . Char.pack
instance IsHashable Text where
hash = hash . Text.unpack
instance IsHashable (Set Hash) where
hash = hash . foldl (<>) "" . Set.toList
instance {-# OVERLAPPABLE #-} IsHashable a => IsHashable [a] where
hash = hash . Set.fromList . map hash
--------------------------------------------------------------------------
data NodeToHash = NodeToHash { nodeType :: NodeType
, nodeId :: NodeId
......
stack.yaml
View file @ 1aa7eefa
......@@ -53,7 +53,7 @@ extra-deps:
- git: https://github.com/np/patches-map
commit: 8c6f38c4844ead53e664cf9c82ba461715dbe445
- git: https://github.com/delanoe/haskell-opaleye.git #- opaleye-0.6.7002.0
commit: 53385de076be09f728a1b58c035a18e9ff9bcfd6
commit: 63ee65d974e9d20eaaf17a2e83652175988cbb79
- git: https://github.com/delanoe/hsparql.git
commit: 308c74b71a1abb0a91546fa57d353131248e3a7f
- Unique-0.4.7.6@sha256:a1ff411f4d68c756e01e8d532fbe8e57f1ac77f2cc0ee8a999770be2bca185c5,2723
......@@ -85,5 +85,5 @@ extra-deps:
- ghc-byteorder-4.11.0.0.10@sha256:5ee4a907279bfec27b0f9de7b8fba4cecfd34395a0235a7784494de70ad4e98f,1535
# Matrix Computation
- accelerate-1.2.0.1
- smtp-mail-0.2.0.0@sha256:b91c81f6dbb41a9ceee8c443385118684ecec55006b77f7d3c0e49cffd2468cf,1211
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