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 TODO-ACCESS Critical
  20
  21 -}
  22
  23 {-# LANGUAGE NoImplicitPrelude #-}
  24 {-# LANGUAGE DeriveGeneric     #-}
  25 {-# LANGUAGE DataKinds         #-}
  26 {-# LANGUAGE OverloadedStrings #-}
  27 {-# LANGUAGE RankNTypes        #-}
  28 {-# LANGUAGE TemplateHaskell   #-}
  29
  30 module Gargantext.API.Auth
  31       where
  32
  33 import Control.Lens (view)
  34 import Control.Monad.IO.Class (liftIO)
  35 import Data.Aeson.TH (deriveJSON)
  36 import Data.List (elem)
  37 import Data.Swagger
  38 import Data.Text (Text, reverse)
  39 import Data.Text.Lazy (toStrict)
  40 import Data.Text.Lazy.Encoding (decodeUtf8)
  41 import GHC.Generics (Generic)
  42 import Servant.Auth.Server
  43 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
  44 import Gargantext.API.Settings
  45 import Gargantext.API.Types (HasJoseError(..), joseError)
  46 import Gargantext.Database.Root (getRoot)
  47 import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId)
  48 import Gargantext.Database.Utils (Cmd', HasConnection)
  49 import Gargantext.Prelude hiding (reverse)
  50 import Test.QuickCheck (elements, oneof)
  51 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  52 import Gargantext.Core.Types.Individu (Username, Password, arbitraryUsername, arbitraryPassword)
  53
  54 ---------------------------------------------------
  55
  56 -- | Main types for AUTH API
  57 data AuthRequest = AuthRequest { _authReq_username :: Username
  58                                , _authReq_password :: Password
  59                                }
  60   deriving (Generic)
  61
  62 -- TODO: Use an HTTP error to wrap AuthInvalid
  63 data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
  64                                  , _authRes_inval :: Maybe AuthInvalid
  65                                  }
  66   deriving (Generic)
  67
  68 data AuthInvalid = AuthInvalid { _authInv_message :: Text }
  69   deriving (Generic)
  70
  71 data AuthValid = AuthValid { _authVal_token   :: Token
  72                            , _authVal_tree_id :: TreeId
  73                            }
  74   deriving (Generic)
  75
  76 type Token  = Text
  77 type TreeId = NodeId
  78
  79 -- | Main functions of authorization
  80
  81
  82 -- | Main types of authorization
  83 data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
  84   deriving (Eq)
  85
  86 makeTokenForUser :: (HasSettings env, HasJoseError err)
  87                  => NodeId -> Cmd' env err Token
  88 makeTokenForUser uid = do
  89   jwtS <- view $ settings . jwtSettings
  90   e <- liftIO $ makeJWT (AuthenticatedUser uid) jwtS Nothing
  91   -- TODO-SECURITY here we can implement token expiration ^^.
  92   either joseError (pure . toStrict . decodeUtf8) e
  93   -- TODO not sure about the encoding...
  94
  95 checkAuthRequest :: (HasSettings env, HasConnection env, HasJoseError err)
  96                  => Username -> Password -> Cmd' env err CheckAuth
  97 checkAuthRequest u p
  98   | not (u `elem` arbitraryUsername) = pure InvalidUser
  99   | u /= reverse p = pure InvalidPassword
 100   | otherwise = do
 101       muId <- head <$> getRoot "user1" -- TODO user1 hard-coded
 102       case _node_id <$> muId of
 103         Nothing  -> pure InvalidUser
 104         Just uid -> do
 105           token <- makeTokenForUser uid
 106           pure $ Valid token uid
 107
 108 auth :: (HasSettings env, HasConnection env, HasJoseError err)
 109      => AuthRequest -> Cmd' env err AuthResponse
 110 auth (AuthRequest u p) = do
 111   checkAuthRequest' <- checkAuthRequest u p
 112   case checkAuthRequest' of
 113     InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
 114     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
 115     Valid to trId   -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
 116
 117 newtype AuthenticatedUser = AuthenticatedUser
 118   { _authUser_id :: NodeId
 119   } deriving (Generic)
 120
 121 $(deriveJSON (unPrefix "_authUser_") ''AuthenticatedUser)
 122 instance ToSchema AuthenticatedUser where
 123   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
 124 instance ToJWT AuthenticatedUser
 125 instance FromJWT AuthenticatedUser
 126
 127 --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
 128
 129 -- TODO-SECURITY why is the CookieSettings necessary?
 130 type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
 131
 132 {-
 133 instance FromBasicAuthData AuthenticatedUser where
 134   fromBasicAuthData authData authCheckFunction = authCheckFunction authData
 135
 136 authCheck :: forall env. env
 137           -> BasicAuthData
 138           -> IO (AuthResult AuthenticatedUser)
 139 authCheck _env (BasicAuthData login password) = pure $
 140   maybe Indefinite Authenticated $ TODO
 141 -}
 142
 143 -- | Instances
 144 $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
 145 instance ToSchema AuthRequest where
 146   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
 147
 148 instance Arbitrary AuthRequest where
 149   arbitrary = elements [ AuthRequest u p
 150                        | u <- arbitraryUsername
 151                        , p <- arbitraryPassword
 152                        ]
 153
 154 $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
 155 instance ToSchema AuthResponse where
 156   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
 157 instance Arbitrary AuthResponse where
 158   arbitrary = oneof [ AuthResponse Nothing . Just      <$> arbitrary
 159                     , flip AuthResponse Nothing . Just <$> arbitrary ]
 160
 161 $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
 162 instance ToSchema AuthInvalid where
 163   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
 164 instance Arbitrary AuthInvalid where
 165   arbitrary = elements [ AuthInvalid m
 166                        | m <- [ "Invalid user", "Invalid password"]
 167                        ]
 168
 169 $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
 170 instance ToSchema AuthValid where
 171   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
 172 instance Arbitrary AuthValid where
 173   arbitrary = elements [ AuthValid to tr
 174                        | to <- ["token0", "token1"]
 175                        , tr <- [1..3]
 176                        ]
 177