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