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)
  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   { _au_id :: NodeId
 119   } deriving (Generic)
 120
 121 $(deriveJSON (unPrefix "_au_") ''AuthenticatedUser)
 122 instance ToSchema AuthenticatedUser
 123 instance ToJWT AuthenticatedUser
 124 instance FromJWT AuthenticatedUser
 125
 126 --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
 127
 128 -- TODO-SECURITY why is the CookieSettings necessary?
 129 type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
 130
 131 {-
 132 instance FromBasicAuthData AuthenticatedUser where
 133   fromBasicAuthData authData authCheckFunction = authCheckFunction authData
 134
 135 authCheck :: forall env. env
 136           -> BasicAuthData
 137           -> IO (AuthResult AuthenticatedUser)
 138 authCheck _env (BasicAuthData login password) = pure $
 139   maybe Indefinite Authenticated $ TODO
 140 -}
 141
 142 -- | Instances
 143 $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
 144 instance ToSchema AuthRequest -- TODO-SWAGGER unPrefix
 145
 146 instance Arbitrary AuthRequest where
 147   arbitrary = elements [ AuthRequest u p
 148                        | u <- arbitraryUsername
 149                        , p <- arbitraryPassword
 150                        ]
 151
 152 $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
 153 instance ToSchema AuthResponse -- TODO-SWAGGER unPrefix
 154 instance Arbitrary AuthResponse where
 155   arbitrary = oneof [ AuthResponse Nothing . Just      <$> arbitrary
 156                     , flip AuthResponse Nothing . Just <$> arbitrary ]
 157
 158 $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
 159 instance ToSchema AuthInvalid -- TODO-SWAGGER unPrefix
 160 instance Arbitrary AuthInvalid where
 161   arbitrary = elements [ AuthInvalid m
 162                        | m <- [ "Invalid user", "Invalid password"]
 163                        ]
 164
 165 $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
 166 instance ToSchema AuthValid -- TODO-SWAGGER unPrefix
 167 instance Arbitrary AuthValid where
 168   arbitrary = elements [ AuthValid to tr
 169                        | to <- ["token0", "token1"]
 170                        , tr <- [1..3]
 171                        ]
 172