Skip to content

P
purescript-gargantext
Commit 4fed7755 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge remote-tracking branch 'origin/login'

parents c8584b86 3ab70a97
Hide whitespace changes
Inline Side-by-side
Showing with 326 additions and 297 deletions
src/Gargantext/Components/Login.purs
View file @ 4fed7755
module Gargantext.Components.Login where
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, jsonEmptyObject, (.?), (:=), (~>))
import Data.Lens (over)
import Data.Maybe (Maybe)
import Control.Monad.Cont.Trans (lift)
import Data.Int as Int
import Data.Lens (over, view)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse_)
import Effect.Class (liftEffect)
import Effect (Effect)
import Effect.Aff (Aff)
import React.DOM (a, button, div, h2, h4, h5, i, input, label, p, span, text)
import React.DOM.Props (_data, _id, _type, aria, className, href, maxLength, name, onClick, onInput, placeholder, role, target, value)
import Thermite (PerformAction, Render, Spec, _render, modifyState, simpleSpec)
import Thermite (PerformAction, Render, Spec, _render, modifyState_, simpleSpec)
import Unsafe.Coerce (unsafeCoerce)
import Web.HTML (window)
import Web.HTML.Window (localStorage)
import Web.Storage.Storage (getItem, setItem)
import Web.Storage.Storage (getItem, setItem, removeItem)
------------------------------------------------------------------------
import Gargantext.Prelude
import Gargantext.Config (toUrl, Path(..), End(..))
import Gargantext.Config.REST (post)
import Gargantext.Components.Modals.Modal (modalHide)
import Gargantext.Components.Login.Types
-- TODO: ask for login (modal) or account creation after 15 mn when user
-- is not logged and has made one search at least
newtype State = State
type State =
{ username :: String
, password :: String
, response :: LoginRes
, authData :: Maybe AuthData
, errorMessage :: String
, loginC :: Boolean
}
initialState :: State
initialState = State
{username : ""
, password : ""
, response : LoginRes {token : ""}
, errorMessage : ""
, loginC : false
}
initialState :: Effect State
initialState = do
authData <- getAuthData
pure
{ authData
, username : ""
, password : ""
, errorMessage : ""
}
data Action
= Login
= PostAuth
| SetUserName String
| SetPassword String
......@@ -49,29 +53,27 @@ data Action
modalSpec :: forall props. Boolean -> String -> Spec State props Action -> Spec State props Action
modalSpec sm t = over _render \render d p s c ->
[ div [ _id "loginModal", className $ "modal myModal" <> if sm then "" else " fade"
, role "dialog"
, _data {show : true}
][ div [ className "modal-dialog"
, role "document"
] [ div [ className "modal-content"]
[ div [ className "modal-header"]
[ h5 [ className "modal-title"
]
[ text $ t
]
, button [ _type "button"
, className "close"
, _data { dismiss : "modal"}
] [ span [ aria {hidden : true}]
[ text "X"]
]
]
, div [ className "modal-body"]
(render d p s c)
]
]
]
, role "dialog"
, _data {show : true}
]
[ div [ className "modal-dialog"
, role "document"
]
[ div [ className "modal-content"]
[ div [ className "modal-header"]
[ h5 [ className "modal-title" ]
[ text t ]
, button [ _type "button"
, className "close"
, _data { dismiss : "modal"}
]
[ span [ aria {hidden : true}] [ text "X"]
]
]
, div [ className "modal-body"] (render d p s c)
]
]
]
]
spec' :: Spec State {} Action
......@@ -82,46 +84,36 @@ renderSpec = simpleSpec performAction render
where
performAction :: PerformAction State {} Action
performAction (SetUserName usr) _ _ = void do
modifyState \(State state) -> State $ state { username = usr }
performAction (SetPassword pwd) _ _ = void do
modifyState \(State state) -> State $ state { password = pwd }
performAction Login _ _ = void do
--lift $ setHash "/search"
liftEffect $ modalHide "loginModal"
modifyState \(State state) -> State $ state {loginC = true}
-- res <- lift $ loginReq $ LoginReq { username : state.username, password : state.password }
-- case res of
-- Left e -> do
-- logs e
-- modifyState \(State s) -> State $ s { errorMessage = e}
-- Right r@(LoginRes response) -> do
-- lift $ setHash "/addCorpus"
-- modifyState \(State s) -> State $ s {response = r, errorMessage = ""}
performAction (SetUserName usr) _ _ =
modifyState_ $ _ { username = usr }
performAction (SetPassword pwd) _ _ =
modifyState_ $ _ { password = pwd }
performAction PostAuth _ {username, password} = do
res <- lift $ postAuthRequest $ AuthRequest {username, password}
case res of
AuthResponse {inval: Just (AuthInvalid {message})} ->
modifyState_ $ _ { errorMessage = message }
AuthResponse {valid} -> do
liftEffect $ setAuthData valid
modifyState_ $ _ {authData = valid, errorMessage = ""}
liftEffect $ modalHide "loginModal"
render :: Render State {} Action
render dispatch _ (State state) _ =
[
div [className "row"]
[
div [className "col-sm-10 col-sm-push-1 col-md-6 col-md-push-3 col-lg-6 col-lg-push-3"]
[
h2 [className "text-primary center m-a-2"]
render dispatch _ state _ =
[ div [className "row"]
[ div [className "col-sm-10 col-sm-push-1 col-md-6 col-md-push-3 col-lg-6 col-lg-push-3"]
[ h2 [className "text-primary center m-a-2"]
[ i [className "material-icons md-36"] [text "control_point"]
, span [className "icon-text"] [text "Gargantext"]
]
, div [className "card-group"]
[
div [className "card"]
[
div [className "card-block"]
[
div [className "center"]
[ div [className "card"]
[ div [className "card-block"]
[ div [className "center"]
[ h4 [className "m-b-0"]
[ span [className "icon-text"] [ text "Connexion"]
]
[ span [className "icon-text"] [ text "Connexion"] ]
, p [className "text-muted"]
[ text $ "Login to your account or",
a [ target "blank",href "https://iscpif.fr/services/applyforourservices/"] [text " ask to get an access"]
......@@ -130,6 +122,7 @@ renderSpec = simpleSpec performAction render
, div []
[ input [_type "hidden",
name "csrfmiddlewaretoken",
-- TODO hard-coded CSRF token
value "Wy52D2nor8kC1r1Y4GrsrSIxQ2eqW8UwkdiQQshMoRwobzU4uldknRUhP0j4WcEM" ]
, div [className "form-group"]
......@@ -141,15 +134,14 @@ renderSpec = simpleSpec performAction render
, div [className "clearfix"] []
]
, div [className "center"]
[
label [] [
div [className "checkbox"]
[ input [_id "terms-accept", _type "checkbox", value "", className "checkbox"]
, text "I accept the terms of uses ",
a [href "http://gitlab.iscpif.fr/humanities/tofu/tree/master"] [text "[Read the terms of use]"]
]
, button [_id "login-button",className "btn btn-primary btn-rounded", _type "submit", onClick \_ -> dispatch $ Login] [text "Login"]
]
[ label []
[ div [className "checkbox"]
[ input [_id "terms-accept", _type "checkbox", value "", className "checkbox"]
, text "I accept the terms of uses ",
a [href "http://gitlab.iscpif.fr/humanities/tofu/tree/master"] [text "[Read the terms of use]"]
]
, button [_id "login-button",className "btn btn-primary btn-rounded", _type "submit", onClick \_ -> dispatch $ PostAuth] [text "Login"]
]
]
]
]
......@@ -179,7 +171,7 @@ renderSpec = simpleSpec performAction render
-- ]
-- , div [ className "modal-body"]
-- [ ul [ className "list-group"] ( map fn1 state.response ) ]
-- [ ul [ className "list-group"] ( map fn1 state.authData ) ]
-- , div [className "modal-footer"]
-- [ button [ _type "button"
......@@ -197,44 +189,28 @@ renderSpec = simpleSpec performAction render
unsafeEventValue :: forall event. event -> String
unsafeEventValue e = (unsafeCoerce e).target.value
getDeviseID :: Effect (Maybe String)
getDeviseID = do
getAuthData :: Effect (Maybe AuthData)
getAuthData = do
w <- window
ls <- localStorage w
getItem "token" ls
setToken :: String -> Effect Unit
setToken s = do
mto <- getItem "token" ls
mti <- getItem "tree_id" ls
pure do
token <- mto
tree_id <- Int.fromString =<< mti
pure $ AuthData {token, tree_id}
setAuthData :: Maybe AuthData -> Effect Unit
setAuthData Nothing = do
w <- window
ls <- localStorage w
setItem "token" s ls
newtype LoginRes = LoginRes
{token :: String
}
newtype LoginReq = LoginReq
{ username :: String
, password :: String
}
loginReq :: LoginReq -> Aff LoginRes
loginReq = post "https://dev.gargantext.org/api/auth/token"
instance decodeLoginRes :: DecodeJson LoginRes where
decodeJson json = do
obj <- decodeJson json
token <- obj .? "token"
pure $ LoginRes { token}
removeItem "token" ls
removeItem "tree_id" ls
setAuthData (Just (AuthData {tree_id, token})) = do
w <- window
ls <- localStorage w
setItem "token" token ls
setItem "tree_id" (show tree_id) ls
instance encodeLoginReq :: EncodeJson LoginReq where
encodeJson (LoginReq obj) =
"username" := obj.username
~> "password" := obj.password
~> jsonEmptyObject
postAuthRequest :: AuthRequest -> Aff AuthResponse
postAuthRequest = post $ toUrl Back Auth Nothing
src/Gargantext/Components/Login/Types.purs 0 → 100644
View file @ 4fed7755
module Gargantext.Components.Login.Types where
import Prelude
import Data.Lens (Iso', iso)
import Data.Argonaut ( class DecodeJson, class EncodeJson, decodeJson, jsonEmptyObject
, (.?), (.??), (:=), (~>)
)
import Data.Maybe (Maybe)
type Username = String
type Password = String
type Token = String
type TreeId = Int
newtype AuthRequest = AuthRequest
{ username :: Username
, password :: Password
}
newtype AuthResponse = AuthResponse
{ valid :: Maybe AuthData
, inval :: Maybe AuthInvalid
}
newtype AuthInvalid = AuthInvalid
{ message :: String }
newtype AuthData = AuthData
{ token :: Token
, tree_id :: TreeId
}
_AuthData :: Iso' AuthData { token :: Token, tree_id :: TreeId }
_AuthData = iso (\(AuthData v) -> v) AuthData
instance decodeAuthInvalid :: DecodeJson AuthInvalid where
decodeJson json = do
obj <- decodeJson json
message <- obj .? "message"
pure $ AuthInvalid {message}
instance decodeAuthResponse :: DecodeJson AuthResponse where
decodeJson json = do
obj <- decodeJson json
valid <- obj .?? "valid"
inval <- obj .?? "inval"
pure $ AuthResponse {valid, inval}
instance decodeAuthData :: DecodeJson AuthData where
decodeJson json = do
obj <- decodeJson json
token <- obj .? "token"
tree_id <- obj .? "tree_id"
pure $ AuthData {token, tree_id}
instance encodeAuthRequest :: EncodeJson AuthRequest where
encodeJson (AuthRequest {username, password}) =
"username" := username
~> "password" := password
~> jsonEmptyObject
src/Gargantext/Components/Tree.purs
View file @ 4fed7755
......@@ -8,6 +8,7 @@ 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(..))
......@@ -26,7 +27,7 @@ import React.DOM.Props (_id, _type, className, href, title, onClick, onInput, pl
import React.DOM.Props as DOM
import Thermite (PerformAction, Render, Spec, createClass, defaultPerformAction, defaultRender, modifyState_, simpleSpec)
import Gargantext.Config (toUrl, End(..), NodeType(..), defaultRoot)
import Gargantext.Config (toUrl, End(..), NodeType(..))
import Gargantext.Config.REST (get, put, post, delete, deleteWithBody)
import Gargantext.Components.Loader as Loader
......@@ -39,6 +40,15 @@ type Props = { root :: ID }
data NTree a = NTree a (Array (NTree a))
instance ntreeFunctor :: Functor NTree where
map f (NTree x ary) = NTree (f x) (map (map f) ary)
-- Keep only the nodes matching the predicate.
-- The root of the tree is always kept.
filterNTree :: forall a. (a -> Boolean) -> NTree a -> NTree a
filterNTree p (NTree x ary) =
NTree x $ map (filterNTree p) $ filter (\(NTree a _) -> p a) ary
type FTree = NTree LNode
data Action = ShowPopOver ID
......@@ -55,40 +65,39 @@ data Action = ShowPopOver ID
type State = { state :: FTree }
-- TODO remove
initialState :: State
initialState = { state: NTree (LNode {id : 3, name : "hello", nodeType : Node, open : true, popOver : false, renameNodeValue : "", createNode : false, nodeValue : "InitialNode", showRenameBox : false}) [] }
mapFTree :: (FTree -> FTree) -> State -> State
mapFTree f {state} = {state: f state}
-- TODO: make it a local function
performAction :: forall props. PerformAction State props Action
performAction (ToggleFolder i) _ _ =
modifyState_ $ mapFTree $ toggleNode i
performAction (ShowPopOver id) _ _ =
modifyState_ $ mapFTree $ popOverNode id
modifyState_ $ mapFTree $ map $ popOverNode id
performAction (ShowRenameBox id) _ _ =
modifyState_ $ mapFTree $ showPopOverNode id
modifyState_ $ mapFTree $ map $ showPopOverNode id
performAction (CancelRename id) _ _ =
modifyState_ $ mapFTree $ showPopOverNode id
modifyState_ $ mapFTree $ map $ showPopOverNode id
performAction (ToggleCreateNode id) _ _ =
modifyState_ $ mapFTree $ showCreateNode id
performAction (DeleteNode nid) _ _ = do
d <- lift $ deleteNode nid
--- TODO : Need to update state once API is called
pure unit
void $ lift $ deleteNode nid
modifyState_ $ mapFTree $ filterNTree (\(LNode {id}) -> id /= nid)
--- TODO : Need to update state once API is called
performAction (Submit rid s'') _ _ = do
d <- lift $ renameNode rid $ RenameValue { name : s''}
-- modifyState_ $ mapFTree $ popOverNode rid
modifyState_ $ mapFTree $ showPopOverNode rid -- add this function to toggle rename function
performAction (Submit rid name) _ _ = do
void $ lift $ renameNode rid $ RenameValue {name}
modifyState_ $ mapFTree $ map $ popOverNode rid
<<< onNode rid (\(LNode node) -> LNode (node { name = name }))
performAction (RenameNode r nid) _ _ =
modifyState_ $ mapFTree $ rename nid r
......@@ -99,21 +108,25 @@ performAction (Create nid) _ _ =
performAction (SetNodeValue v nid) _ _ =
modifyState_ $ mapFTree $ setNodeValue nid v
toggleIf :: Boolean -> Boolean -> Boolean
toggleIf true = not
toggleIf false = const false
popOverNode :: Int -> NTree LNode -> NTree LNode
popOverNode sid (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, createNode, nodeValue, showRenameBox}) ary) =
NTree (LNode {id,name, nodeType, open , popOver : npopOver, renameNodeValue, createNode, nodeValue, showRenameBox}) $ map (popOverNode sid) ary
where
npopOver = if sid == id then not popOver else popOver
onNode :: Int -> (LNode -> LNode) -> LNode -> LNode
onNode id f l@(LNode node)
| node.id == id = f l
| otherwise = l
showPopOverNode :: Int -> NTree LNode -> NTree LNode
showPopOverNode sid (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, createNode, nodeValue, showRenameBox}) ary) =
NTree (LNode {id,name, nodeType, open , popOver , renameNodeValue, createNode, nodeValue, showRenameBox: nshowRenameBox}) $ map (showPopOverNode sid) ary
where
nshowRenameBox = if sid == id then not showRenameBox else showRenameBox
popOverNode :: Int -> LNode -> LNode
popOverNode sid (LNode node) =
LNode $ node { popOver = toggleIf (sid == node.id) node.popOver
, showRenameBox = false }
showPopOverNode :: Int -> 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 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
......@@ -129,21 +142,21 @@ showCreateNode sid (NTree (LNode {id, name, nodeType, open, popOver, renameNodeV
-- NTree (LNode {id,name, nodeType, open , popOver, renameNodeValue, createNode , nodeValue}) $ map (getCreateNode sid) ary
-- createNode' = if sid == id then nodeValue else ""
-- TODO: DRY, NTree.map
rename :: Int -> 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 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 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
......@@ -252,7 +265,7 @@ renameTreeView d s@(NTree (LNode {id, name, nodeType, open, popOver, renameNodeV
[
input [ _type "text"
, placeholder "Rename Node"
, defaultValue $ getRenameNodeValue s
, defaultValue $ name
, style {float: "left"}
, className "col-md-2 form-control"
, onInput \e -> d (RenameNode (unsafeEventValue e) nid)
......@@ -335,10 +348,6 @@ renameTreeViewDummy d s = div [] []
popOverValue :: FTree -> Boolean
popOverValue (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, showRenameBox }) ary) = popOver
getRenameNodeValue :: FTree -> String
getRenameNodeValue (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, showRenameBox }) ary) = renameNodeValue
getCreateNodeValue :: FTree -> String
getCreateNodeValue (NTree (LNode {id, name, nodeType, open, popOver, renameNodeValue, nodeValue, showRenameBox}) ary) = nodeValue
......@@ -420,8 +429,8 @@ newtype RenameValue = RenameValue
}
instance encodeJsonRenameValue :: EncodeJson RenameValue where
encodeJson (RenameValue post)
= "r_name" := post.name
encodeJson (RenameValue {name})
= "r_name" := name
~> jsonEmptyObject
renameNode :: Int -> RenameValue -> Aff (Array Int)
......
src/Gargantext/Config.purs
View file @ 4fed7755
......@@ -27,11 +27,6 @@ endConfig' :: ApiVersion -> EndConfig
endConfig' v = { front : frontRelative
, back : backLocal v }
-- | Default Root on shared database to develop
-- until authentication implementation
-- (Default Root will be given after authentication)
defaultRoot :: Int
defaultRoot = 950094
------------------------------------------------------------------------
frontRelative :: Config
frontRelative = { baseUrl: ""
......@@ -100,25 +95,41 @@ endOf Front = _.front
endBaseUrl :: End -> EndConfig -> UrlBase
endBaseUrl end c = (endOf end c).baseUrl
endPathUrl :: End -> EndConfig -> NodeType -> Maybe Id -> UrlPath
endPathUrl end c nt i = pathUrl (endOf end c) nt i
endPathUrl :: End -> EndConfig -> Path -> Maybe Id -> UrlPath
endPathUrl end = pathUrl <<< endOf end
pathUrl :: Config -> NodeType -> Maybe Id -> UrlPath
pathUrl c nt@(Tab _ _ _ _) i = pathUrl c Node i <> "/" <> show nt
pathUrl c nt@(Ngrams _ _) i = pathUrl c Node i <> "/" <> show nt
pathUrl c nt i = c.prePath <> urlConfig nt <> (maybe "" (\i' -> "/" <> show i') i)
------------------------------------------------------------
toUrl :: End -> NodeType -> Maybe Id -> Url
toUrl e nt i = doUrl base path params
pathUrl :: Config -> Path -> Maybe Id -> UrlPath
pathUrl c (Tab t o l s) i =
pathUrl c (NodeAPI Node) i <>
"/" <> "table?view=" <> show t <> "&offset=" <> show o
<> "&limit=" <> show l <> os
where
os = maybe "" (\x -> "&order=" <> show x) s
pathUrl c (Ngrams t listid) i =
pathUrl c (NodeAPI Node) i <> "/" <> "listGet?ngramsType=" <> show t <> listid'
where
base = endBaseUrl e endConfig
path = endPathUrl e endConfig nt i
params = ""
listid' = maybe "" (\x -> "&list=" <> show x) listid
pathUrl c Auth Nothing = c.prePath <> "auth"
pathUrl c Auth (Just _) = "impossible" -- TODO better types
pathUrl c (NodeAPI nt) i = c.prePath <> nodeTypeUrl nt <> (maybe "" (\i' -> "/" <> show i') i)
------------------------------------------------------------
class ToUrl a where
toUrl :: End -> a -> Maybe Id -> Url
instance toUrlNodeType :: ToUrl NodeType where
toUrl e nt i = toUrl e (NodeAPI nt) i
instance toUrlPath :: ToUrl Path where
toUrl e p i = doUrl base path params
where
base = endBaseUrl e endConfig
path = endPathUrl e endConfig p i
params = ""
------------------------------------------------------------
data NodeType = NodeUser
| Annuaire
| Tab TabType Offset Limit (Maybe OrderBy)
| Ngrams TabType (Maybe TermList)
| Corpus
| CorpusV3
| Dashboard
......@@ -130,6 +141,13 @@ data NodeType = NodeUser
| Node
| Nodes
| Tree
data Path
= Auth
| Tab TabType Offset Limit (Maybe OrderBy)
| Ngrams TabType (Maybe TermList)
| NodeAPI NodeType
data End = Back | Front
type Id = Int
......@@ -162,56 +180,23 @@ instance showTabType :: Show TabType where
show TabTrash = "Trash"
------------------------------------------------------------
urlConfig :: NodeType -> Url
urlConfig Annuaire = show Annuaire
urlConfig nt@(Tab _ _ _ _) = show nt
urlConfig nt@(Ngrams _ _) = show nt
urlConfig Corpus = show Corpus
urlConfig CorpusV3 = show CorpusV3
urlConfig Dashboard = show Dashboard
urlConfig Url_Document = show Url_Document
urlConfig Error = show Error
urlConfig Folder = show Folder
urlConfig Graph = show Graph
urlConfig Individu = show Individu
urlConfig Node = show Node
urlConfig Nodes = show Nodes
urlConfig NodeUser = show NodeUser
urlConfig Tree = show Tree
------------------------------------------------------------
instance showNodeType :: Show NodeType where
show Annuaire = "annuaire"
show Corpus = "corpus"
show CorpusV3 = "corpus"
show Dashboard = "dashboard"
show Url_Document = "document"
show Error = "ErrorNodeType"
show Folder = "folder"
show Graph = "graph"
show Individu = "individu"
show Node = "node"
show Nodes = "nodes"
show NodeUser = "user"
show Tree = "tree"
show (Tab t o l s) = "table?view=" <> show t <> "&offset=" <> show o
<> "&limit=" <> show l <> os
where
os = maybe "" (\x -> "&order=" <> show x) s
show (Ngrams t listid) = "listGet?ngramsType=" <> show t <> listid'
where
listid' = maybe "" (\x -> "&list=" <> show x) listid
-- | TODO : where is the Read Class ?
-- NP: We don't need the Read class. Here are the encoding formats we need:
-- * JSON
-- * URL parts has in {To,From}HttpApiData but only for certain types
-- The Show class should only be used for dev.
nodeTypeUrl :: NodeType -> Url
nodeTypeUrl Annuaire = "annuaire"
nodeTypeUrl Corpus = "corpus"
nodeTypeUrl CorpusV3 = "corpus"
nodeTypeUrl Dashboard = "dashboard"
nodeTypeUrl Url_Document = "document"
nodeTypeUrl Error = "ErrorNodeType"
nodeTypeUrl Folder = "folder"
nodeTypeUrl Graph = "graph"
nodeTypeUrl Individu = "individu"
nodeTypeUrl Node = "node"
nodeTypeUrl Nodes = "nodes"
nodeTypeUrl NodeUser = "user"
nodeTypeUrl Tree = "tree"
-- instance readNodeType :: Read NodeType where
readNodeType :: String -> NodeType
readNodeType "NodeAnnuaire" = Annuaire
readNodeType "Tab" = (Tab TabDocs 0 0 Nothing)
readNodeType "Ngrams" = (Ngrams TabTerms Nothing)
readNodeType "NodeDashboard" = Dashboard
readNodeType "Document" = Url_Document
readNodeType "NodeFolder" = Folder
......@@ -224,12 +209,14 @@ readNodeType "NodeCorpusV3" = CorpusV3
readNodeType "NodeUser" = NodeUser
readNodeType "Tree" = Tree
readNodeType _ = Error
{-
------------------------------------------------------------
instance ordNodeType :: Ord NodeType where
compare n1 n2 = compare (show n1) (show n2)
instance eqNodeType :: Eq NodeType where
eq n1 n2 = eq (show n1) (show n2)
-}
------------------------------------------------------------
instance decodeJsonNodeType :: DecodeJson NodeType where
decodeJson json = do
......
src/Gargantext/Pages/Annuaire.purs
View file @ 4fed7755
......@@ -22,7 +22,7 @@ import Gargantext.Prelude
import Gargantext.Components.Loader as Loader
import Gargantext.Components.Tab as Tab
import Gargantext.Components.Table as T
import Gargantext.Config (toUrl, NodeType(..), TabType(..), End(..))
import Gargantext.Config (toUrl, Path(..), NodeType(..), TabType(..), End(..))
import Gargantext.Config.REST (get)
import Gargantext.Pages.Annuaire.User.Contacts.Types (Contact(..), HyperData(..), HyperdataContact(..))
------------------------------------------------------------------------------
......
src/Gargantext/Pages/Corpus/Tabs/Documents.purs
View file @ 4fed7755
......@@ -25,7 +25,7 @@ import React as React
import React (ReactClass, ReactElement, Children)
------------------------------------------------------------------------
import Gargantext.Prelude
import Gargantext.Config (NodeType(..), TabType(..), toUrl, End(..), OrderBy(..))
import Gargantext.Config (Path(..), NodeType(..), TabType(..), toUrl, End(..), OrderBy(..))
import Gargantext.Config.REST (get, put, post, deleteWithBody)
import Gargantext.Utils.DecodeMaybe ((.|))
import Gargantext.Components.Charts.Options.ECharts (chart)
......
src/Gargantext/Pages/Corpus/Tabs/Ngrams/NgramsTable.purs
View file @ 4fed7755
......@@ -46,7 +46,6 @@ import Gargantext.Components.Table as T
import Gargantext.Prelude
import Gargantext.Config
import Gargantext.Config.REST
import Gargantext.Components.Tree (NTree(..))
import Gargantext.Components.Loader as Loader
import Gargantext.Pages.Corpus.Tabs.Types (CorpusInfo(..), PropsRow)
......
src/Gargantext/Pages/Layout/Actions.purs
View file @ 4fed7755
......@@ -2,16 +2,15 @@
module Gargantext.Pages.Layout.Actions where
import Control.Monad.Cont.Trans (lift)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Lens (Prism', prism)
import Effect.Class (liftEffect)
import Thermite (PerformAction, modifyState, modifyState_)
import Routing.Hash (setHash)
import Gargantext.Config (defaultRoot)
import Gargantext.Components.Login as LN
import Gargantext.Components.Modals.Modal (modalShow)
import Gargantext.Components.Tree as Tree
import Gargantext.Pages.Annuaire as Annuaire
import Gargantext.Pages.Annuaire.User.Contacts as C
import Gargantext.Pages.Corpus.Document as D
......@@ -36,6 +35,7 @@ data Action
| UserPageA C.Action
| Go
| ShowLogin
| Logout
| ShowAddcorpus
| ShowTree
......@@ -46,13 +46,20 @@ performAction (SetRoute route) _ _ = void do
performAction (Search s) _ _ = void do
modifyState $ _ {search = s}
performAction (ShowTree) _ (state) = void do
performAction (ShowTree) _ (state) = void do -- TODO
modifyState $ _ {showTree = not (state.showTree)}
performAction (ShowLogin) _ _ = void do
liftEffect $ modalShow "loginModal"
modifyState $ _ {showLogin = true}
performAction Logout _ _ = do
loginState <- liftEffect do
LN.setAuthData Nothing
setHash "/"
LN.initialState
modifyState_ $ _ {currentRoute = Nothing, loginState = loginState}
---------------------------------------------------------
-- TODO chose one of them
performAction (ShowAddcorpus) _ _ = void do
......
src/Gargantext/Pages/Layout/Specs.purs
View file @ 4fed7755
......@@ -11,8 +11,8 @@ import Thermite (Render, Spec, _render, defaultPerformAction, defaultRender, foc
import Unsafe.Coerce (unsafeCoerce)
import Gargantext.Prelude
import Gargantext.Config (defaultRoot)
import Gargantext.Components.Data.Lang (Lang(..))
import Gargantext.Components.Login.Types (AuthData(..))
import Gargantext.Components.Login as LN
import Gargantext.Components.Tree as Tree
import Gargantext.Folder as F
......@@ -22,7 +22,6 @@ import Gargantext.Pages.Corpus as Corpus
import Gargantext.Pages.Corpus.Document as Annotation
import Gargantext.Pages.Corpus.Dashboard as Dsh
import Gargantext.Pages.Corpus.Graph as GE
import Gargantext.Pages.Corpus.Tabs.Ngrams.NgramsTable as NG
import Gargantext.Pages.Home as L
import Gargantext.Pages.Layout.Actions (Action(..), _addCorpusAction, _documentViewAction, _graphExplorerAction, _loginAction, _searchAction, _userPageAction, performAction)
import Gargantext.Pages.Layout.Specs.AddCorpus as AC
......@@ -85,10 +84,12 @@ layout0 layout =
outerLayout =
cont $ fold
[ withState \st ->
if ((\(LN.State s) -> s.loginC) st.loginState == true)
then ls $ cmapProps (const {root: defaultRoot}) as
else outerLayout1
, rs bs
case st.loginState.authData of
Just (AuthData {tree_id}) ->
ls $ cmapProps (const {root: tree_id}) as
Nothing ->
outerLayout1
, rs bs
]
ls = over _render \render d p s c -> [
div [ className "col-md-2"] (render d p s c)
......@@ -124,10 +125,12 @@ layout1 layout =
outerLayout =
cont $ fold
[ withState \st ->
if ((\(LN.State s) -> s.loginC) st.loginState == true)
then ls $ cmapProps (const {root: defaultRoot}) as
else outerLayout1
, rs bs
case st.loginState.authData of
Just (AuthData {tree_id}) ->
ls $ cmapProps (const {root: tree_id}) as
Nothing ->
outerLayout1
, rs bs
]
ls = over _render \render d p s c -> [
......@@ -164,7 +167,7 @@ layoutSidebar = over _render \render d p s c ->
, div [ className "collapse navbar-collapse"]
$ [ divDropdownLeft]
<> render d p s c <>
[ divDropdownRight d]
[ divDropdownRight d s ]
]
]
]
......@@ -308,29 +311,35 @@ divSearchBar = simpleSpec performAction render
]
]
--divDropdownRight :: Render AppState {} Action
divDropdownRight :: (Action -> Effect Unit) -> ReactElement
divDropdownRight d =
divDropdownRight :: (Action -> Effect Unit) -> AppState -> ReactElement
divDropdownRight d s =
ul [className "nav navbar-nav pull-right"]
[
-- TODO if logged in : enable dropdown to logout
li [className "dropdown"]
[
a [ aria {hidden : true}
, className "glyphicon glyphicon-log-in"
, --href "#/login"
onClick $ \e -> d ShowLogin
, style {color:"white"}
, title "Log in and save your time"
-- TODO hover: bold
]
-- TODO if logged in
--, text " username"
-- else
[text " Login / Signup"]
]
[ li [className "dropdown"]
[ case s.loginState.authData of
Nothing -> loginLink
Just _ -> logoutLink
]
]
where
loginLink =
a [ aria {hidden : true}
, className "glyphicon glyphicon-log-in"
, onClick $ \e -> d ShowLogin
, style {color:"white"}
, title "Log in and save your time"
-- TODO hover: bold
]
[text " Login / Signup"]
-- TODO dropdown to logout
logoutLink =
a [ aria {hidden : true}
, className "glyphicon glyphicon-log-out"
, onClick $ \e -> d Logout
, style {color:"white"}
, title "Log out" -- TODO
-- TODO hover: bold
]
[text " Logout"]
layoutFooter :: Spec AppState {} Action
layoutFooter = simpleSpec performAction render
......
src/Gargantext/Pages/Layout/States.purs
View file @ 4fed7755
......@@ -4,8 +4,8 @@ import Prelude hiding (div)
import Data.Lens (Lens', lens)
import Data.Maybe (Maybe(Just))
import Effect (Effect)
import Gargantext.Components.Login as LN
import Gargantext.Components.Tree as Tree
import Gargantext.Pages.Corpus.Document as D
import Gargantext.Pages.Corpus.Graph as GE
......@@ -28,20 +28,22 @@ type AppState =
, showTree :: Boolean
}
initAppState :: AppState
initAppState =
{ currentRoute : Just Home
, loginState : LN.initialState
, addCorpusState : AC.initialState
, searchState : S.initialState
, userPageState : C.initialState
, documentState : D.initialState {}
, search : ""
, showLogin : false
, showCorpus : false
, graphExplorerState : GE.initialState
, showTree : false
}
initAppState :: Effect AppState
initAppState = do
loginState <- LN.initialState
pure
{ currentRoute : Just Home
, loginState
, addCorpusState : AC.initialState
, searchState : S.initialState
, userPageState : C.initialState
, documentState : D.initialState {}
, search : ""
, showLogin : false
, showCorpus : false
, graphExplorerState : GE.initialState
, showTree : false
}
---------------------------------------------------------
_loginState :: Lens' AppState LN.State
......
src/Gargantext/Router.purs
View file @ 4fed7755
......@@ -57,24 +57,3 @@ instance showRoutes :: Show Routes where
show Dashboard = "Dashboard"
show (PGraphExplorer i) = "graphExplorer" <> show i
show Home = "Home"
routeHandler :: (Maybe Routes -> Routes -> Effect Unit)
-> Maybe Routes -> Routes -> Effect Unit
routeHandler dispatchAction old new = do
logs $ "change route : " <> show new
w <- window
ls <- localStorage w
token <- getItem "accessToken" ls
let tkn = token
logs $ "JWToken : " <> show tkn
case tkn of
Nothing -> do
dispatchAction old new
logs $ "called SignIn Route :"
Just t -> do
dispatchAction old new
logs $ "called Route : " <> show new
src/Main.purs
View file @ 4fed7755
......@@ -7,7 +7,7 @@ import Effect (Effect)
import Gargantext.Pages.Layout (dispatchAction)
import Gargantext.Pages.Layout.Specs (layoutSpec)
import Gargantext.Pages.Layout.States (initAppState)
import Gargantext.Router (routeHandler, routing)
import Gargantext.Router (routing)
import Partial.Unsafe (unsafePartial)
import React as R
import ReactDOM as RDOM
......@@ -24,10 +24,11 @@ setUnsafeComponentWillMount = unsafeSet "unsafeComponentWillMount"
main :: Effect Unit
main = do
case T.createReactSpec layoutSpec (const initAppState) of
state <- initAppState
case T.createReactSpec layoutSpec (const state) of
{ spec, dispatcher } -> void $ do
let setRouting this = void $ do
matches routing (routeHandler (dispatchAction (dispatcher this)))
matches routing (dispatchAction (dispatcher this))
spec' this = setUnsafeComponentWillMount (setRouting this) <$> (spec this)
document <- window >>= document
container <- unsafePartial (fromJust <$> querySelector (QuerySelector "#app") (toParentNode document))
......
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