[API][AUTH] if authorized then id of tree is given (with token).

src/Gargantext/API.hs

@@ -36,14 +36,15 @@ Thanks @yannEsposito for this.
 module Gargantext.API
       where
 ---------------------------------------------------------------------
-import           Gargantext.Prelude
 
+import           Database.PostgreSQL.Simple (Connection)
 import           System.IO (FilePath)
 
 import           GHC.Generics (D1, Meta (..), Rep)
 import           GHC.TypeLits (AppendSymbol, Symbol)
 
 import           Control.Lens
+import Control.Monad.IO.Class (liftIO)
 import           Data.Aeson.Encode.Pretty (encodePretty)
 import qualified Data.ByteString.Lazy.Char8 as BL8
 import           Data.Swagger
@@ -62,8 +63,10 @@ import           Servant.Swagger.UI
 -- import Servant.API.Stream
 
 --import Gargantext.API.Swagger
+import Gargantext.Prelude
 import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
 
+import Gargantext.API.Auth (AuthRequest, AuthResponse, auth')
 import Gargantext.API.Node ( Roots    , roots
                            , NodeAPI  , nodeAPI
                            , NodesAPI , nodesAPI
@@ -76,6 +79,7 @@ import Gargantext.API.Node ( Roots    , roots
 import Gargantext.Database.Types.Node ()
 import Gargantext.API.Count  ( CountAPI, count, Query)
 import Gargantext.API.Search ( SearchAPI, search, SearchQuery)
+
 --import Gargantext.API.Orchestrator
 --import Gargantext.API.Orchestrator.Types
 
@@ -200,10 +204,17 @@ type GargAPI = "api" :> Summary "API " :> GargAPIVersion
 
 type GargAPIVersion = "v1.0" :> Summary "v1.0: " :> GargAPI'
 
+auth :: Connection -> AuthRequest -> Handler AuthResponse
+auth conn ar = liftIO $ auth' conn ar
+
 type GargAPI' =
+           -- Auth endpoint
+           "auth"      :> Summary "AUTH API"
+                       :> ReqBody '[JSON] AuthRequest
+                       :> Post    '[JSON] AuthResponse
           
            -- Roots endpoint
-                "user"  :> Summary "First user endpoint"
+          :<|>  "user"  :> Summary "First user endpoint"
                         :> Roots
            
            -- Node endpoint
@@ -251,14 +262,15 @@ type GargAPI' =
 ---------------------------------------------------------------------
 type SwaggerFrontAPI = SwaggerAPI :<|> FrontEndAPI 
 
-type API = SwaggerFrontAPI :<|> GargAPI
 
+type API = SwaggerFrontAPI :<|> GargAPI
 ---------------------------------------------------------------------
 -- | Server declaration
 server :: Env -> IO (Server API)
 server env = do
   -- orchestrator <- scrapyOrchestrator env
   pure $ swaggerFront
+     :<|> auth    conn
      :<|> roots    conn
      :<|> nodeAPI  conn (Proxy :: Proxy HyperdataAny)
      :<|> nodeAPI  conn (Proxy :: Proxy HyperdataCorpus)

src/Gargantext/API/Auth.hs

@@ -18,18 +18,114 @@ Main authorisation of Gargantext are managed in this module
 
 -}
 
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 
 module Gargantext.API.Auth
       where
 
---import Gargantext.Prelude
+import Data.Aeson.TH (deriveJSON)
+import Data.List (elem)
+import Data.Swagger
+import Data.Text (Text, reverse)
+import Database.PostgreSQL.Simple (Connection)
+import GHC.Generics (Generic)
+import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Database.Node (getRootUsername)
+import Gargantext.Database.Types.Node (NodePoly(_node_id))
+import Gargantext.Prelude hiding (reverse)
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+
+---------------------------------------------------
+
+-- | Main types for AUTH API
+type Username = Text
+type Password = Text
+
+data AuthRequest = AuthRequest { _authReq_username :: Username
+                               , _authReq_password :: Password
+                               }
+  deriving (Generic)
+
+data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
+                                 , _authRes_inval :: Maybe AuthInvalid
+                                 }
+  deriving (Generic)
+
+data AuthInvalid = AuthInvalid { _authInv_message :: Text }
+  deriving (Generic)
+
+data AuthValid = AuthValid { _authVal_token   :: Token
+                           , _authVal_tree_id :: TreeId
+                           }
+  deriving (Generic)
+
+type Token  = Text
+type TreeId = Int
+
+-- | Main functions of authorization
+
+
+-- | Main types of authorization
+data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
+  deriving (Eq)
+
+arbitraryUsername :: [Username]
+arbitraryUsername = ["user1", "user2"]
+
+arbitraryPassword :: [Password]
+arbitraryPassword = map reverse arbitraryUsername
+
+checkAuthRequest :: Username -> Password -> Connection -> IO CheckAuth
+checkAuthRequest u p c = case elem u arbitraryUsername of
+    False -> pure InvalidUser
+    True  -> case u == (reverse p) of
+               False -> pure InvalidPassword
+               True  -> do
+                 muId <- getRootUsername u c
+                 let uId = maybe (panic "API.AUTH: no user node") _node_id $ head muId
+                 pure $ Valid "token" uId
+
+
+auth' :: Connection -> AuthRequest -> IO AuthResponse
+auth' c (AuthRequest u p) = do
+  checkAuthRequest' <- checkAuthRequest u p c
+  case checkAuthRequest' of
+    InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
+    InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
+    Valid to trId   -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
+
+-- | Instances
+$(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
+instance ToSchema AuthRequest
+
+instance Arbitrary AuthRequest where
+  arbitrary = elements [ AuthRequest u p
+                       | u <- arbitraryUsername
+                       , p <- arbitraryPassword
+                       ]
+
+$(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
+instance ToSchema AuthResponse
+instance Arbitrary AuthResponse where
+  arbitrary = AuthResponse <$> arbitrary <*> arbitrary
+
+$(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
+instance ToSchema AuthInvalid
+instance Arbitrary AuthInvalid where
+  arbitrary = elements [ AuthInvalid m 
+                       | m <- [ "Invalid user", "Invalid password"]
+                       ]
 
---data Auth = Auth { username :: Text
---                 , password :: Text
---                 } deriving (Generics)
+$(deriveJSON (unPrefix "_authVal_") ''AuthValid)
+instance ToSchema AuthValid
+instance Arbitrary AuthValid where
+  arbitrary = elements [ AuthValid to tr
+                       | to <- ["token0", "token1"]
+                       , tr <- [1..3]
+                       ]
 

src/Gargantext/Database/Flow.hs

@@ -96,7 +96,7 @@ subFlow username cName = do
   rootId' <- map _node_id <$> runCmd' (getRoot userId)
 
   rootId'' <- case rootId' of
-        []  -> runCmd' (mkRoot userId)
+        []  -> runCmd' (mkRoot username userId)
         n   -> case length n >= 2 of
             True  -> panic "Error: more than 1 userNode / user"
             False -> pure rootId'

src/Gargantext/Database/Node.hs

@@ -206,6 +206,17 @@ selectNode id = proc () -> do
 runGetNodes :: Query NodeRead -> Cmd [NodeAny]
 runGetNodes q = mkCmd $ \conn -> runQuery conn q
 
+------------------------------------------------------------------------
+selectRootUsername :: Username -> Query NodeRead
+selectRootUsername username = proc () -> do
+    row <- queryNodeTable -< ()
+    restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
+    restrict -< _node_name   row .== (pgStrictText username)
+    returnA -< row
+
+getRootUsername :: Username -> Connection -> IO [Node HyperdataUser]
+getRootUsername uname conn = runQuery conn (selectRootUsername uname)
+
 ------------------------------------------------------------------------
 selectRootUser :: UserId -> Query NodeRead
 selectRootUser userId = proc () -> do
@@ -512,10 +523,12 @@ mk'' NodeUser _       _   _     = panic "NodeUser do not have any parent"
 mk'' _        Nothing _   _     = panic "NodeType does   have a   parent"
 mk'' nt       pId     uId name  = mkCmd $ \c -> mk' c nt uId pId name
 
-mkRoot :: UserId -> Cmd [Int]
-mkRoot uId = case uId > 0 of
+type Username = Text
+
+mkRoot :: Username -> UserId -> Cmd [Int]
+mkRoot uname uId = case uId > 0 of
                False -> panic "UserId <= 0"
-               True  -> mk'' NodeUser Nothing uId ("User Node : " <> (pack . show) uId)
+               True  -> mk'' NodeUser Nothing uId uname
 
 mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
 mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]