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.Root (getRoot)
  38 import Gargantext.Database.Types.Node (NodePoly(_node_id))
  39 import Gargantext.Prelude hiding (reverse)
  40 import Test.QuickCheck (elements, oneof)
  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 -- TODO: Use an HTTP error to wrap AuthInvalid
  55 data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
  56                                  , _authRes_inval :: Maybe AuthInvalid
  57                                  }
  58   deriving (Generic)
  59
  60 data AuthInvalid = AuthInvalid { _authInv_message :: Text }
  61   deriving (Generic)
  62
  63 data AuthValid = AuthValid { _authVal_token   :: Token
  64                            , _authVal_tree_id :: TreeId
  65                            }
  66   deriving (Generic)
  67
  68 type Token  = Text
  69 type TreeId = Int
  70
  71 -- | Main functions of authorization
  72
  73
  74 -- | Main types of authorization
  75 data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
  76   deriving (Eq)
  77
  78 arbitraryUsername :: [Username]
  79 arbitraryUsername = ["gargantua", "user1", "user2"]
  80
  81 arbitraryPassword :: [Password]
  82 arbitraryPassword = map reverse arbitraryUsername
  83
  84 checkAuthRequest :: Username -> Password -> Connection -> IO CheckAuth
  85 checkAuthRequest u p c
  86   | not (u `elem` arbitraryUsername) = pure InvalidUser
  87   | u /= reverse p = pure InvalidPassword
  88   | otherwise = do
  89       muId <- getRoot u c
  90       pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
  91
  92 auth' :: Connection -> AuthRequest -> IO AuthResponse
  93 auth' c (AuthRequest u p) = do
  94   checkAuthRequest' <- checkAuthRequest u p c
  95   case checkAuthRequest' of
  96     InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
  97     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
  98     Valid to trId   -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
  99
 100 -- | Instances
 101 $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
 102 instance ToSchema AuthRequest
 103
 104 instance Arbitrary AuthRequest where
 105   arbitrary = elements [ AuthRequest u p
 106                        | u <- arbitraryUsername
 107                        , p <- arbitraryPassword
 108                        ]
 109
 110 $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
 111 instance ToSchema AuthResponse
 112 instance Arbitrary AuthResponse where
 113   arbitrary = oneof [ AuthResponse Nothing . Just      <$> arbitrary
 114                     , flip AuthResponse Nothing . Just <$> arbitrary ]
 115
 116 $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
 117 instance ToSchema AuthInvalid
 118 instance Arbitrary AuthInvalid where
 119   arbitrary = elements [ AuthInvalid m
 120                        | m <- [ "Invalid user", "Invalid password"]
 121                        ]
 122
 123 $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
 124 instance ToSchema AuthValid
 125 instance Arbitrary AuthValid where
 126   arbitrary = elements [ AuthValid to tr
 127                        | to <- ["token0", "token1"]
 128                        , tr <- [1..3]
 129                        ]
 130