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))
  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
  44 ---------------------------------------------------
  45
  46 -- | Main types for AUTH API
  47 type Username = Text
  48 type Password = Text
  49
  50 data AuthRequest = AuthRequest { _authReq_username :: Username
  51                                , _authReq_password :: Password
  52                                }
  53   deriving (Generic)
  54
  55 -- TODO: Use an HTTP error to wrap AuthInvalid
  56 data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
  57                                  , _authRes_inval :: Maybe AuthInvalid
  58                                  }
  59   deriving (Generic)
  60
  61 data AuthInvalid = AuthInvalid { _authInv_message :: Text }
  62   deriving (Generic)
  63
  64 data AuthValid = AuthValid { _authVal_token   :: Token
  65                            , _authVal_tree_id :: TreeId
  66                            }
  67   deriving (Generic)
  68
  69 type Token  = Text
  70 type TreeId = Int
  71
  72 -- | Main functions of authorization
  73
  74
  75 -- | Main types of authorization
  76 data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
  77   deriving (Eq)
  78
  79 arbitraryUsername :: [Username]
  80 arbitraryUsername = ["gargantua", "user1", "user2"]
  81
  82 arbitraryPassword :: [Password]
  83 arbitraryPassword = map reverse arbitraryUsername
  84
  85 checkAuthRequest :: Username -> Password -> Cmd err CheckAuth
  86 checkAuthRequest u p
  87   | not (u `elem` arbitraryUsername) = pure InvalidUser
  88   | u /= reverse p = pure InvalidPassword
  89   | otherwise = do
  90       muId <- getRoot u
  91       pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
  92
  93 auth :: AuthRequest -> Cmd err AuthResponse
  94 auth (AuthRequest u p) = do
  95   checkAuthRequest' <- checkAuthRequest u p
  96   case checkAuthRequest' of
  97     InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
  98     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
  99     Valid to trId   -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
 100
 101 -- | Instances
 102 $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
 103 instance ToSchema AuthRequest
 104
 105 instance Arbitrary AuthRequest where
 106   arbitrary = elements [ AuthRequest u p
 107                        | u <- arbitraryUsername
 108                        , p <- arbitraryPassword
 109                        ]
 110
 111 $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
 112 instance ToSchema AuthResponse
 113 instance Arbitrary AuthResponse where
 114   arbitrary = oneof [ AuthResponse Nothing . Just      <$> arbitrary
 115                     , flip AuthResponse Nothing . Just <$> 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