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 TemplateHaskell   #-}
  26
  27 module Gargantext.API.Auth
  28       where
  29
  30 import Data.Aeson.TH (deriveJSON)
  31 import Data.List (elem)
  32 import Data.Swagger
  33 import Data.Text (Text, reverse)
  34 import Database.PostgreSQL.Simple (Connection)
  35 import GHC.Generics (Generic)
  36 import Gargantext.Core.Utils.Prefix (unPrefix)
  37 import Gargantext.Database.Node (getRootUsername)
  38 import Gargantext.Database.Types.Node (NodePoly(_node_id))
  39 import Gargantext.Prelude hiding (reverse)
  40 import Test.QuickCheck (elements)
  41 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  42
  43 ---------------------------------------------------
  44
  45 -- | Main types for AUTH API
  46 type Username = Text
  47 type Password = Text
  48
  49 data AuthRequest = AuthRequest { _authReq_username :: Username
  50                                , _authReq_password :: Password
  51                                }
  52   deriving (Generic)
  53
  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 = Int
  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 arbitraryUsername :: [Username]
  78 arbitraryUsername = ["user1", "user2"]
  79
  80 arbitraryPassword :: [Password]
  81 arbitraryPassword = map reverse arbitraryUsername
  82
  83 checkAuthRequest :: Username -> Password -> Connection -> IO CheckAuth
  84 checkAuthRequest u p c = case elem u arbitraryUsername of
  85     False -> pure InvalidUser
  86     True  -> case u == (reverse p) of
  87                False -> pure InvalidPassword
  88                True  -> do
  89                  muId <- getRootUsername u c
  90                  let uId = maybe (panic "API.AUTH: no user node") _node_id $ head muId
  91                  pure $ Valid "token" uId
  92
  93
  94 auth' :: Connection -> AuthRequest -> IO AuthResponse
  95 auth' c (AuthRequest u p) = do
  96   checkAuthRequest' <- checkAuthRequest u p c
  97   case checkAuthRequest' of
  98     InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
  99     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
 100     Valid to trId   -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
 101
 102 -- | Instances
 103 $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
 104 instance ToSchema AuthRequest
 105
 106 instance Arbitrary AuthRequest where
 107   arbitrary = elements [ AuthRequest u p
 108                        | u <- arbitraryUsername
 109                        , p <- arbitraryPassword
 110                        ]
 111
 112 $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
 113 instance ToSchema AuthResponse
 114 instance Arbitrary AuthResponse where
 115   arbitrary = AuthResponse <$> arbitrary <*> arbitrary
 116
 117 $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
 118 instance ToSchema AuthInvalid
 119 instance Arbitrary AuthInvalid where
 120   arbitrary = elements [ AuthInvalid m
 121                        | m <- [ "Invalid user", "Invalid password"]
 122                        ]
 123
 124 $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
 125 instance ToSchema AuthValid
 126 instance Arbitrary AuthValid where
 127   arbitrary = elements [ AuthValid to tr
 128                        | to <- ["token0", "token1"]
 129                        , tr <- [1..3]
 130                        ]
 131