Skip to content

P
purescript-gargantext
Commit 027ae537 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

tree: create new corpus button 

- some Tree.purs code cleanup (imports)
- file upload via drop onto tree node
parent f8fa5702
Show whitespace changes
Inline Side-by-side
Showing with 162 additions and 83 deletions
.psc-package/local/.set/packages.json
View file @ 027ae537
......@@ -570,6 +570,16 @@
"repo": "https://github.com/purescript/purescript-distributive.git",
"version": "v4.0.0"
},
"dom-filereader": {
"dependencies": [
"aff",
"arraybuffer-types",
"web-file",
"web-html"
],
"repo": "https://github.com/nwolverson/purescript-dom-filereader",
"version": "v5.0.0"
},
"dom-indexed": {
"dependencies": [
"media-types",
......
packages.dhall
View file @ 027ae537
......@@ -173,6 +173,15 @@ let additions =
]
"https://github.com/irresponsible/purescript-dom-simple"
"v0.2.4"
, dom-filereader =
mkPackage
[ "aff"
, "arraybuffer-types"
, "web-file"
, "web-html"
]
"https://github.com/nwolverson/purescript-dom-filereader"
"v5.0.0"
, reactix =
mkPackage
[ "console"
......
psc-package.json
View file @ 027ae537
......@@ -3,30 +3,31 @@
"set": "local",
"source": ".psc-package",
"depends": [
"numbers",
"spec-quickcheck",
"spec-discovery",
"uint",
"js-timers",
"psci-support",
"css",
"generics-rep",
"maybe",
"routing",
"foreign-object",
"affjax",
"argonaut",
"console",
"css",
"dom-filereader",
"dom-simple",
"effect",
"web-html",
"thermite",
"foreign-object",
"generics-rep",
"integers",
"random",
"affjax",
"console",
"strings",
"string-parsers",
"js-timers",
"maybe",
"numbers",
"prelude",
"dom-simple",
"psci-support",
"random",
"reactix",
"uri"
"routing",
"spec-discovery",
"spec-quickcheck",
"string-parsers",
"strings",
"thermite",
"uint",
"uri",
"web-html"
]
}
src/Gargantext/Components/Tree.purs
View file @ 027ae537
module Gargantext.Components.Tree where
import Prelude hiding (div)
import Unsafe.Coerce
import Unsafe.Coerce (unsafeCoerce)
import Affjax (defaultRequest, printResponseFormatError, request)
import Affjax.RequestBody (RequestBody(..))
import Affjax.ResponseFormat as ResponseFormat
import CSS (backgroundColor, borderRadius, boxShadow, justifyContent, marginTop)
import Control.Monad.Cont.Trans (lift)
import Data.Array (filter)
import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson, jsonEmptyObject, (.?), (:=), (~>))
import Data.Argonaut.Core (Json)
import Data.Either (Either(..))
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, jsonEmptyObject, (.:), (:=), (~>))
import Data.Maybe (Maybe(..), fromJust)
import Data.Newtype (class Newtype)
import DOM.Simple.Console
import DOM.Simple.Console (log2)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Aff (Aff, runAff)
import Effect.Class (liftEffect)
import Effect.Console (log)
import Prelude (identity)
import FFI.Simple ((..))
import Partial.Unsafe (unsafePartial)
import React (ReactClass, ReactElement)
import React as React
import React.DOM (a, button, div, h5, i, input, li, span, text, ul, b, u)
import React.DOM.Props (_id, _type, className, href, title, onClick, onInput, placeholder, style, defaultValue, _data)
import React.DOM.Props (_id, _type, className, href, title, onClick, onDrop, onDragOver, onInput, placeholder, style, defaultValue, _data)
import React.DOM.Props as DOM
import Thermite (PerformAction, Render, Spec, createClass, defaultPerformAction, defaultRender, modifyState_, simpleSpec, modifyState)
import React.SyntheticEvent as E
import Thermite (PerformAction, Render, Spec, createClass, defaultPerformAction, simpleSpec, modifyState_)
import Web.File.File (toBlob)
import Web.File.FileReader.Aff (readAsText)
import Web.File.FileList (FileList, item)
import Gargantext.Config (toUrl, End(..), NodeType(..), urlPlease)
import Gargantext.Config.REST (get, put, post, delete, deleteWithBody)
import Gargantext.Config.REST (get, put, post, postWwwUrlencoded, delete)
import Gargantext.Components.Loader as Loader
type Name = String
......@@ -51,6 +48,7 @@ filterNTree p (NTree x ary) =
NTree x $ map (filterNTree p) $ filter (\(NTree a _) -> p a) ary
type FTree = NTree LNode
type FileHash = String
data Action = ShowPopOver ID
| ToggleFolder ID
......@@ -64,13 +62,24 @@ data Action = ShowPopOver ID
| ShowRenameBox ID
| CancelRename ID
| CurrentNode ID
| UploadFile ID String
type State = { state :: FTree
, currentNode :: Maybe Int
, currentNode :: Maybe ID
}
-- TODO remove
initialNode :: { createNode :: Boolean
, id :: ID
, name :: String
, nodeType :: NodeType
, nodeValue :: String
, open :: Boolean
, popOver :: Boolean
, renameNodeValue :: String
, showRenameBox :: Boolean
}
initialNode = { id : 3
, name : "hello"
, nodeType : Node
......@@ -132,31 +141,35 @@ performAction (SetNodeValue v nid) _ _ =
performAction (CurrentNode nid) _ _ =
modifyState_ $ \{state: s} -> {state: s, currentNode : Just nid}
performAction (UploadFile nid contents) _ _ = do
hashes <- lift $ uploadFile nid contents
liftEffect $ log2 "uploaded:" hashes
toggleIf :: Boolean -> Boolean -> Boolean
toggleIf true = not
toggleIf false = const false
onNode :: Int -> (LNode -> LNode) -> LNode -> LNode
onNode :: ID -> (LNode -> LNode) -> LNode -> LNode
onNode id f l@(LNode node)
| node.id == id = f l
| otherwise = l
popOverNode :: Int -> LNode -> LNode
popOverNode :: ID -> LNode -> LNode
popOverNode sid (LNode node) =
LNode $ node { popOver = toggleIf (sid == node.id) node.popOver
, showRenameBox = false }
hidePopOverNode :: Int -> LNode -> LNode
hidePopOverNode :: ID -> LNode -> LNode
hidePopOverNode sid (LNode node) =
LNode $ node { popOver = false }
showPopOverNode :: Int -> LNode -> LNode
showPopOverNode :: ID -> LNode -> LNode
showPopOverNode sid (LNode node) =
LNode $ node {showRenameBox = toggleIf (sid == node.id) node.showRenameBox}
-- TODO: DRY, NTree.map
showCreateNode :: Int -> NTree LNode -> NTree LNode
showCreateNode :: ID -> NTree LNode -> NTree LNode
showCreateNode sid (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, createNode, nodeValue, showRenameBox}) ary) =
NTree (LNode {id,name, nodeType, open , popOver, renameNodeValue, createNode : createNode', nodeValue, showRenameBox}) $ map (showCreateNode sid) ary
where
......@@ -164,7 +177,7 @@ showCreateNode sid (NTree (LNode {id, name, nodeType, open, popOver, renameNodeV
----TODO get id and value to send API to call
-- getCreateNode :: Int -> NTree LNode -> String
-- getCreateNode :: ID -> NTree LNode -> String
-- getCreateNode sid (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, createNode, nodeValue}) ary) =
-- createNode
-- where
......@@ -172,21 +185,21 @@ showCreateNode sid (NTree (LNode {id, name, nodeType, open, popOver, renameNodeV
-- createNode' = if sid == id then nodeValue else ""
-- TODO: DRY, NTree.map
rename :: Int -> String -> NTree LNode -> NTree LNode
rename :: ID -> String -> NTree LNode -> NTree LNode
rename sid v (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, createNode, nodeValue, showRenameBox}) ary) =
NTree (LNode {id,name, nodeType, open , popOver , renameNodeValue : rvalue, createNode, nodeValue, showRenameBox}) $ map (rename sid v) ary
where
rvalue = if sid == id then v else ""
-- TODO: DRY, NTree.map
setNodeValue :: Int -> String -> NTree LNode -> NTree LNode
setNodeValue :: ID -> String -> NTree LNode -> NTree LNode
setNodeValue sid v (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, createNode, nodeValue, showRenameBox}) ary) =
NTree (LNode {id,name, nodeType, open , popOver , renameNodeValue , createNode, nodeValue : nvalue, showRenameBox}) $ map (setNodeValue sid v) ary
where
nvalue = if sid == id then v else ""
-- TODO: DRY, NTree.map
toggleNode :: Int -> NTree LNode -> NTree LNode
toggleNode :: ID -> NTree LNode -> NTree LNode
toggleNode sid (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, createNode, nodeValue, showRenameBox}) ary) =
NTree (LNode {id,name, nodeType, open : nopen, popOver, renameNodeValue, createNode, nodeValue, showRenameBox}) $ map (toggleNode sid) ary
where
......@@ -207,12 +220,12 @@ exampleTree = NTree (LNode {id : 1, name : "", nodeType : Node, open : false, po
-- --, corpus 3 "IMT publications"
-- ]
-- annuaire :: ID -> String -> NTree (Tuple String String)
-- annuaire n name = NTree n false name
-- [ NTree (Tuple "IMT community" "#/docView")
-- ]
-- corpus :: ID -> String -> NTree (Tuple String String)
-- corpus n name = NTree (LNode {id : n, name, nodeType : "", open : false})
-- [ NTree (Tuple "Facets" "#/corpus") []
-- , NTree (Tuple "Dashboard" "#/dashboard") []
......@@ -279,7 +292,7 @@ treeview = simpleSpec defaultPerformAction render
, component: treeViewClass
} ]
renameTreeView :: (Action -> Effect Unit) -> FTree -> Int -> ReactElement
renameTreeView :: (Action -> Effect Unit) -> FTree -> ID -> ReactElement
renameTreeView d s@(NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, showRenameBox }) ary) nid =
div [className "col-md-12", _id "rename-tooltip",className "btn btn-secondary", _data {toggle : "tooltip", placement : "right"}, title "Settings on right"]
[ div [_id "arrow"] []
......@@ -376,7 +389,7 @@ renameTreeView d s@(NTree (LNode {id, name, nodeType, open, popOver, renameNodeV
createNodeView :: (Action -> Effect Unit) -> FTree -> Int -> ReactElement
createNodeView :: (Action -> Effect Unit) -> FTree -> ID -> ReactElement
createNodeView d s@(NTree (LNode {id, name, nodeType, open, popOver, nodeValue }) ary) nid =
div [className ""]
[ div [className "panel panel-default"]
......@@ -415,11 +428,11 @@ getCreateNodeValue :: FTree -> String
getCreateNodeValue (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, nodeValue, showRenameBox}) ary) = nodeValue
toHtml :: (Action -> Effect Unit) -> FTree -> Maybe Int -> ReactElement
toHtml :: (Action -> Effect Unit) -> FTree -> Maybe ID -> ReactElement
toHtml d s@(NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, createNode,nodeValue, showRenameBox }) []) n =
ul []
[
li [] $
li [] $ [span []
[ a [className "glyphicon glyphicon-cog", _id "rename-leaf",onClick $ (\_-> d $ (ShowPopOver id))] []
, a [ href (toUrl Front nodeType (Just id)), style {"margin-left":"22px"}
, onClick $ (\e -> d $ CurrentNode id)
......@@ -428,58 +441,75 @@ toHtml d s@(NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, cr
, if (popOver == true) then (renameTreeView d s id) else (renameTreeViewDummy d s)
, if (createNode == true) then (createNodeView d s id) else (renameTreeViewDummy d s)
]
]
]]
--- need to add renameTreeview value to this function
toHtml d s@(NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue,createNode, nodeValue, showRenameBox}) ary) n=
toHtml d s@(NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, createNode, nodeValue, showRenameBox}) ary) n =
ul []
[ li [] $
( [ a [onClick $ (\e-> d $ ToggleFolder id)] [i [fldr open] []]
( [span [onDrop dropHandler, onDragOver onDragOverHandler] [
a [onClick $ (\e-> d $ ToggleFolder id)] [i [fldr open] []]
, a [ href (toUrl Front nodeType (Just id)), style {"margin-left":"22px"}
, onClick $ (\e -> d $ CurrentNode id)
]
--[ text name ]
[ if n == (Just id) then u [] [b [] [text $ "| " <> name <> " |"]] else text name ]
, a [className "glyphicon glyphicon-cog", _id "rename",onClick $ (\_-> d $ (ShowPopOver id))]
[
]
, a [ className "glyphicon glyphicon-cog"
, _id "rename"
, onClick $ (\_-> d $ (ShowPopOver id))
] []
, if (popOver == true) then (renameTreeView d s id) else (renameTreeViewDummy d s)
, if (createNode == true) then (createNodeView d s id) else (renameTreeViewDummy d s)
] <>
if open then
]
] <> if open then
map (\s -> toHtml d s n) ary
else []
)
]
where
dropHandler = \e -> unsafePartial $ do
let ff = fromJust $ item 0 $ ((e .. "dataTransfer" .. "files") :: FileList)
liftEffect $ log2 "drop:" ff
-- prevent redirection when file is dropped
E.preventDefault e
E.stopPropagation e
let blob = toBlob $ ff
void $ runAff (\_ -> pure unit) do
contents <- readAsText blob
liftEffect $ d $ UploadFile id contents
onDragOverHandler = \e -> do
-- prevent redirection when file is dropped
-- https://stackoverflow.com/a/6756680/941471
E.preventDefault e
E.stopPropagation e
fldr :: Boolean -> DOM.Props
fldr open = if open then className "fas fa-folder-open" else className "fas fa-folder"
newtype LNode = LNode {id :: Int, name :: String, nodeType :: NodeType, open :: Boolean, popOver :: Boolean, renameNodeValue :: String, nodeValue :: String, createNode :: Boolean, showRenameBox :: Boolean}
newtype LNode = LNode {id :: ID, name :: String, nodeType :: NodeType, open :: Boolean, popOver :: Boolean, renameNodeValue :: String, nodeValue :: String, createNode :: Boolean, showRenameBox :: Boolean}
derive instance newtypeLNode :: Newtype LNode _
instance decodeJsonLNode :: DecodeJson LNode where
decodeJson json = do
obj <- decodeJson json
id_ <- obj .? "id"
name <- obj .? "name"
nodeType <- obj .? "type"
id_ <- obj .: "id"
name <- obj .: "name"
nodeType <- obj .: "type"
pure $ LNode {id : id_, name, nodeType, open : true, popOver : false, renameNodeValue : "", createNode : false, nodeValue : "", showRenameBox : false}
instance decodeJsonFTree :: DecodeJson (NTree LNode) where
decodeJson json = do
obj <- decodeJson json
node <- obj .? "node"
nodes <- obj .? "children"
node <- obj .: "node"
nodes <- obj .: "children"
node' <- decodeJson node
nodes' <- decodeJson nodes
pure $ NTree node' nodes'
loadNode :: Int -> Aff FTree
loadNode :: ID -> Aff FTree
loadNode = get <<< toUrl Back Tree <<< Just
----- TREE CRUD Operations
......@@ -506,21 +536,27 @@ instance encodeJsonCreateValue :: EncodeJson CreateValue where
~> "files_id" := ([] :: Array String)
~> jsonEmptyObject
createNode :: CreateValue -> Aff Int
type UploadFileContents = String
createNode :: CreateValue -> Aff ID
createNode = post $ urlPlease Back $ "new"
renameNode :: Int -> RenameValue -> Aff (Array Int)
renameNode :: ID -> RenameValue -> Aff (Array ID)
renameNode renameNodeId = put $ toUrl Back Node (Just renameNodeId) <> "/rename"
deleteNode :: Int -> Aff Int
deleteNode :: ID -> Aff ID
deleteNode = delete <<< toUrl Back Node <<< Just
uploadFile :: ID -> UploadFileContents -> Aff (Array FileHash)
uploadFile id = postWwwUrlencoded $ toUrl Back Node (Just id) <> "/upload"
--uploadFile = postWwwUrlencoded $ urlPlease Back $ "upload"
-- UNUSED
-- deleteNodes :: TODO -> Aff Int
-- deleteNodes :: TODO -> Aff ID
-- deleteNodes = deleteWithBody (toUrl Back Nodes Nothing)
-- UNUSED
-- createNode :: TODO -> Aff Int
-- createNode :: TODO -> Aff ID
-- createNode = post (toUrl Back Node Nothing)
fnTransform :: LNode -> FTree
......
src/Gargantext/Config/REST.purs
View file @ 027ae537
module Gargantext.Config.REST where
import Gargantext.Prelude
import Affjax (defaultRequest, printResponseFormatError, request)
import Affjax.RequestBody (RequestBody(..))
import Affjax.RequestBody (RequestBody(..), string)
import Affjax.RequestHeader (RequestHeader(..))
import Affjax.ResponseFormat as ResponseFormat
import Data.Argonaut (class DecodeJson, decodeJson, class EncodeJson, encodeJson)
import Data.Either (Either(..))
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.MediaType.Common (applicationJSON)
import Data.MediaType.Common (applicationFormURLEncoded, applicationJSON)
import Effect.Aff (Aff, throwError)
import Effect.Exception (error)
import Gargantext.Prelude
send :: forall a b. EncodeJson a => DecodeJson b =>
Method -> String -> Maybe a -> Aff b
send m url reqbody = do
......@@ -58,3 +58,26 @@ deleteWithBody url = send DELETE url <<< Just
post :: forall a b. EncodeJson a => DecodeJson b => String -> a -> Aff b
post url = send POST url <<< Just
postWwwUrlencoded :: forall b. DecodeJson b => String -> String -> Aff b
postWwwUrlencoded url body = do
affResp <- request $ defaultRequest
{ url = url
, responseFormat = ResponseFormat.json
, method = Left POST
, headers = [ ContentType applicationFormURLEncoded
, Accept applicationJSON
]
, content = Just $ string body
}
case affResp.body of
Left err -> do
_ <- logs $ printResponseFormatError err
throwError $ error $ printResponseFormatError err
Right json -> do
--_ <- logs $ show json.status
--_ <- logs $ show json.headers
--_ <- logs $ show json.body
case decodeJson json of
Left err -> throwError $ error $ "decodeJson affResp.body: " <> err
Right b -> pure b
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