src/Gargantext/API/Auth.hs

   1 {-|
   2 Module      : Gargantext.API.Auth
   3 Description : Server API Auth Module
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Main authorisation of Gargantext are managed in this module
  11
  12 -- 1: Implement the Server / Client JWT authentication
  13       -> Client towards Python Backend
  14       -> Server towards Purescript Front-End
  15
  16 -- 2: Implement the Auth API backend
  17     https://github.com/haskell-servant/servant-auth
  18
  19 -}
  20
  21 {-# LANGUAGE NoImplicitPrelude #-}
  22 {-# LANGUAGE DeriveGeneric     #-}
  23 {-# LANGUAGE DataKinds         #-}
  24 {-# LANGUAGE OverloadedStrings #-}
  25 {-# LANGUAGE RankNTypes        #-}
  26 {-# LANGUAGE TemplateHaskell   #-}
  27
  28 module Gargantext.API.Auth
  29       where
  30
  31 import Data.Aeson.TH (deriveJSON)
  32 import Data.List (elem)
  33 import Data.Swagger
  34 import Data.Text (Text, reverse)
  35 import GHC.Generics (Generic)
  36 import Gargantext.Core.Utils.Prefix (unPrefix)
  37 import Gargantext.Database.Root (getRoot)
  38 import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId)
  39 import Gargantext.Database.Utils (Cmd)
  40 import Gargantext.Prelude hiding (reverse)
  41 import Test.QuickCheck (elements, oneof)
  42 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  43 import Gargantext.Core.Types.Individu (Username, Password, arbitraryUsername, arbitraryPassword)
  44
  45 ---------------------------------------------------
  46
  47 -- | Main types for AUTH API
  48 data AuthRequest = AuthRequest { _authReq_username :: Username
  49                                , _authReq_password :: Password
  50                                }
  51   deriving (Generic)
  52
  53 -- TODO: Use an HTTP error to wrap AuthInvalid
  54 data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
  55                                  , _authRes_inval :: Maybe AuthInvalid
  56                                  }
  57   deriving (Generic)
  58
  59 data AuthInvalid = AuthInvalid { _authInv_message :: Text }
  60   deriving (Generic)
  61
  62 data AuthValid = AuthValid { _authVal_token   :: Token
  63                            , _authVal_tree_id :: TreeId
  64                            }
  65   deriving (Generic)
  66
  67 type Token  = Text
  68 type TreeId = NodeId
  69
  70 -- | Main functions of authorization
  71
  72
  73 -- | Main types of authorization
  74 data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
  75   deriving (Eq)
  76
  77 checkAuthRequest :: Username -> Password -> Cmd err CheckAuth
  78 checkAuthRequest u p
  79   | not (u `elem` arbitraryUsername) = pure InvalidUser
  80   | u /= reverse p = pure InvalidPassword
  81   | otherwise = do
  82       muId <- getRoot "user1"
  83       pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
  84
  85 auth :: AuthRequest -> Cmd err AuthResponse
  86 auth (AuthRequest u p) = do
  87   checkAuthRequest' <- checkAuthRequest u p
  88   case checkAuthRequest' of
  89     InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
  90     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
  91     Valid to trId   -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
  92
  93 -- | Instances
  94 $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
  95 instance ToSchema AuthRequest
  96
  97 instance Arbitrary AuthRequest where
  98   arbitrary = elements [ AuthRequest u p
  99                        | u <- arbitraryUsername
 100                        , p <- arbitraryPassword
 101                        ]
 102
 103 $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
 104 instance ToSchema AuthResponse
 105 instance Arbitrary AuthResponse where
 106   arbitrary = oneof [ AuthResponse Nothing . Just      <$> arbitrary
 107                     , flip AuthResponse Nothing . Just <$> arbitrary ]
 108
 109 $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
 110 instance ToSchema AuthInvalid
 111 instance Arbitrary AuthInvalid where
 112   arbitrary = elements [ AuthInvalid m
 113                        | m <- [ "Invalid user", "Invalid password"]
 114                        ]
 115
 116 $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
 117 instance ToSchema AuthValid
 118 instance Arbitrary AuthValid where
 119   arbitrary = elements [ AuthValid to tr
 120                        | to <- ["token0", "token1"]
 121                        , tr <- [1..3]
 122                        ]
 123