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