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 authorization 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, GargServerC)
  49 --import Gargantext.API.Types (HasJoseError(..), joseError, HasServerError, serverError, GargServerC)
  50 import Gargantext.Database.Root (getRoot)
  51 import Gargantext.Database.Tree (isDescendantOf, isIn)
  52 import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId(..), UserId, ListId, DocId)
  53 import Gargantext.Database.Utils (Cmd', CmdM, HasConnection)
  54 import Gargantext.Prelude hiding (reverse)
  55 import Test.QuickCheck (elements, oneof)
  56 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  57 import Gargantext.Core.Types.Individu (Username, Password, arbitraryUsername, arbitraryPassword)
  58
  59 ---------------------------------------------------
  60
  61 -- | Main types for AUTH API
  62 data AuthRequest = AuthRequest { _authReq_username :: Username
  63                                , _authReq_password :: Password
  64                                }
  65   deriving (Generic)
  66
  67 -- TODO: Use an HTTP error to wrap AuthInvalid
  68 data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
  69                                  , _authRes_inval :: Maybe AuthInvalid
  70                                  }
  71   deriving (Generic)
  72
  73 data AuthInvalid = AuthInvalid { _authInv_message :: Text }
  74   deriving (Generic)
  75
  76 data AuthValid = AuthValid { _authVal_token   :: Token
  77                            , _authVal_tree_id :: TreeId
  78                            }
  79   deriving (Generic)
  80
  81 type Token  = Text
  82 type TreeId = NodeId
  83
  84 -- | Main functions of authorization
  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 u
 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 data PathId = PathNode NodeId | PathNodeNode ListId DocId
 183
 184 withAccessM :: (CmdM env err m, HasServerError err)
 185             => UserId
 186             -> PathId
 187             -> m a
 188             -> m a
 189 withAccessM uId (PathNode id) m = do
 190   d <- id `isDescendantOf` NodeId uId
 191   if d then m else m -- serverError err401
 192
 193 withAccessM uId (PathNodeNode cId docId) m = do
 194   _a <- isIn cId docId -- TODO use one query for all ?
 195   _d <- cId `isDescendantOf` NodeId uId
 196   if True -- a && d
 197      then m
 198      else m
 199
 200 withAccess :: forall env err m api.
 201               (GargServerC env err m, HasServer api '[]) =>
 202               Proxy api -> Proxy m ->
 203               UserId -> PathId ->
 204               ServerT api m -> ServerT api m
 205 withAccess p _ uId id = hoistServer p f
 206   where
 207     f :: forall a. m a -> m a
 208     f = withAccessM uId id
 209
 210 {- | Collaborative Schema
 211 User at his root can create Teams Folder
 212 User can create Team in Teams Folder.
 213 User can invite User in Team as NodeNode only if Team in his parents.
 214 All users can access to the Team folder as if they were owner.
 215 -}