[FIX] Order 1 and Order 2, node size ok.
[gargantext.git] / src / Gargantext / API / Admin / Auth.hs
index 571f4a9b447c1759d18b18b0e89e6a130965fa48..c05a0f452fb22693058aa350747fde3fbc9d024a 100644 (file)
@@ -20,72 +20,39 @@ TODO-ACCESS Critical
 
 -}
 
-{-# LANGUAGE NoImplicitPrelude   #-}
-{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE MonoLocalBinds      #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell     #-}
 
 module Gargantext.API.Admin.Auth
-      where
+  ( auth
+  , withAccess
+  )
+  where
 
 import Control.Lens (view)
-import Data.Aeson.TH (deriveJSON)
-import Data.List (elem)
-import Data.Swagger
-import Data.Text (Text, reverse)
 import Data.Text.Lazy (toStrict)
 import Data.Text.Lazy.Encoding (decodeUtf8)
-import GHC.Generics (Generic)
-import Gargantext.API.Admin.Settings
+import Servant
+import Servant.Auth.Server
+import qualified Gargantext.Prelude.Crypto.Auth as Auth
+
+import Gargantext.API.Admin.Auth.Types
+import Gargantext.API.Admin.Types
 import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC)
-import Gargantext.Core.Types.Individu (User(..), Username, Password, arbitraryUsername, arbitraryPassword)
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
+import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
+import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
+import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
 import Gargantext.Database.Query.Tree.Root (getRoot)
-import Gargantext.Database.Schema.Node (NodePoly(_node_id)) 
-import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId, ListId, DocId)
-import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool)
+import Gargantext.Database.Schema.Node (NodePoly(_node_id))
 import Gargantext.Prelude hiding (reverse)
-import Servant
-import Servant.Auth.Server
-import Test.QuickCheck (elements, oneof)
-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
 ---------------------------------------------------
 
--- | Main types for AUTH API
-data AuthRequest = AuthRequest { _authReq_username :: Username
-                               , _authReq_password :: Password
-                               }
-  deriving (Generic)
-
--- TODO: Use an HTTP error to wrap AuthInvalid
-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 = NodeId
-
 -- | Main functions of authorization
 
--- | Main types of authorization
-data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
-  deriving (Eq)
-
 makeTokenForUser :: (HasSettings env, HasJoseError err)
                  => NodeId -> Cmd' env err Token
 makeTokenForUser uid = do
@@ -95,20 +62,26 @@ makeTokenForUser uid = do
   either joseError (pure . toStrict . decodeUtf8) e
   -- TODO not sure about the encoding...
 
-checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err)
-                 => Username -> Password -> Cmd' env err CheckAuth
-checkAuthRequest u p
-  | not (u `elem` arbitraryUsername) = pure InvalidUser
-  | u /= reverse p = pure InvalidPassword
-  | otherwise = do
-      muId <- head <$> getRoot (UserName u)
-      case _node_id <$> muId of
-        Nothing  -> pure InvalidUser
-        Just uid -> do
-          token <- makeTokenForUser uid
-          pure $ Valid token uid
-
-auth :: (HasSettings env, HasConnectionPool env, HasJoseError err)
+checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
+                 => Username
+                 -> GargPassword
+                 -> Cmd' env err CheckAuth
+checkAuthRequest u (GargPassword p) = do
+  candidate <- head <$> getUsersWith u
+  case candidate of
+    Nothing -> pure InvalidUser
+    Just (UserLight _id _u _email h) ->
+      case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
+        Auth.PasswordCheckFail    -> pure InvalidPassword
+        Auth.PasswordCheckSuccess -> do
+          muId <- head <$> getRoot (UserName u)
+          case _node_id <$> muId of
+            Nothing  -> pure InvalidUser
+            Just uid -> do
+              token <- makeTokenForUser uid
+              pure $ Valid token uid
+
+auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
      => AuthRequest -> Cmd' env err AuthResponse
 auth (AuthRequest u p) = do
   checkAuthRequest' <- checkAuthRequest u p
@@ -117,21 +90,8 @@ auth (AuthRequest u p) = do
     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
     Valid to trId   -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
 
-newtype AuthenticatedUser = AuthenticatedUser
-  { _authUser_id :: NodeId
-  } deriving (Generic)
-
-$(deriveJSON (unPrefix "_authUser_") ''AuthenticatedUser)
-instance ToSchema AuthenticatedUser where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
-instance ToJWT AuthenticatedUser
-instance FromJWT AuthenticatedUser
-
 --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
 
--- TODO-SECURITY why is the CookieSettings necessary?
-type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
-
 {-
 instance FromBasicAuthData AuthenticatedUser where
   fromBasicAuthData authData authCheckFunction = authCheckFunction authData
@@ -143,43 +103,6 @@ authCheck _env (BasicAuthData login password) = pure $
   maybe Indefinite Authenticated $ TODO
 -}
 
--- | Instances
-$(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
-instance ToSchema AuthRequest where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
-
-instance Arbitrary AuthRequest where
-  arbitrary = elements [ AuthRequest u p
-                       | u <- arbitraryUsername
-                       , p <- arbitraryPassword
-                       ]
-
-$(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
-instance ToSchema AuthResponse where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
-instance Arbitrary AuthResponse where
-  arbitrary = oneof [ AuthResponse Nothing . Just      <$> arbitrary
-                    , flip AuthResponse Nothing . Just <$> arbitrary ]
-
-$(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
-instance ToSchema AuthInvalid where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
-instance Arbitrary AuthInvalid where
-  arbitrary = elements [ AuthInvalid m 
-                       | m <- [ "Invalid user", "Invalid password"]
-                       ]
-
-$(deriveJSON (unPrefix "_authVal_") ''AuthValid)
-instance ToSchema AuthValid where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
-instance Arbitrary AuthValid where
-  arbitrary = elements [ AuthValid to tr
-                       | to <- ["token0", "token1"]
-                       , tr <- [1..3]
-                       ]
-
-data PathId = PathNode NodeId | PathNodeNode ListId DocId
-
 withAccessM :: (CmdM env err m, HasServerError err)
             => UserId
             -> PathId
@@ -198,8 +121,7 @@ withAccessM uId (PathNodeNode cId docId) m = do
 
 withAccess :: forall env err m api.
               (GargServerC env err m, HasServer api '[]) =>
-              Proxy api -> Proxy m ->
-              UserId -> PathId ->
+              Proxy api -> Proxy m -> UserId -> PathId ->
               ServerT api m -> ServerT api m
 withAccess p _ uId id = hoistServer p f
   where