[BUG] server with auth (ReaderT and RessourceT).

package.yaml

@@ -78,10 +78,11 @@ library:
   - filepath
   - fclabels
   - fast-logger
-    #  - haskell-gi-base
+#  - haskell-gi-base
   - http-conduit
   - http-api-data
   - http-types
+  - http-client
   - hxt
   - ini
   - jose-jwt
@@ -115,6 +116,7 @@ library:
   - servant-static-th
   - split
   - swagger2
+  - stm
   - tagsoup
   - text-metrics
   - time

src/Gargantext/API/Auth.hs

@@ -16,18 +16,179 @@ Main authorisation of Gargantext are managed in this module
 -- 2: Implement the Auth API backend
     https://github.com/haskell-servant/servant-auth
 
+Credits: http://blog.wuzzeb.org/full-stack-web-haskell/libraries.html
 -}
 
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-{-# LANGUAGE DataKinds       #-}
-{-# LANGUAGE TemplateHaskell #-}
+
+{-# LANGUAGE DataKinds                   #-}
+{-# LANGUAGE DeriveGeneric               #-}
+{-# LANGUAGE ScopedTypeVariables         #-}
+{-# LANGUAGE TemplateHaskell             #-}
+{-# LANGUAGE OverloadedStrings           #-}
+{-# LANGUAGE FlexibleInstances           #-}
+{-# LANGUAGE TypeOperators               #-}
 
 module Gargantext.API.Auth
       where
 
---import Gargantext.Prelude
+------------------------------------------------------------------------
+
+import GHC.Int (Int64)
+import GHC.Generics (Generic)
+
+import Control.Lens hiding ((.=))
+import Control.Applicative
+import Control.Monad.Reader
+
+import Data.Aeson
+import qualified Data.Aeson as Aeson
+import Data.Either (Either(Left, Right))
+import Data.Time.Clock.POSIX (POSIXTime(), getPOSIXTime)
+import Data.Text
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.ByteString.Lazy (fromStrict, toStrict)
+
+import Servant
+import qualified Jose.Jwa as Jose
+import qualified Jose.Jwt as Jose
 
+import Gargantext.Prelude hiding (drop)
+import Gargantext.API
+import Gargantext.API.Settings
+------------------------------------------------------------------------
+
+type UserId = Int
+
+-- | User credentials extracted from the JWT token
 --data Auth = Auth { username :: Text
 --                 , password :: Text
 --                 } deriving (Generics)
+data UserCredentials = UserCredentials { _credId            :: UserId
+                                       , _credEmail         :: Text
+                                       , _credEmailVerified :: Bool
+                                       }
+    deriving (Show, Eq, Generic)
+
+makeLenses ''UserCredentials
+
+-- | There are two kinds of tokens.  When reseting the password, we send
+-- a token via email.  When a user logs in, we send a token to the browser.
+data TokenAudience = TokenSentViaEmail | TokenSentToBrowser | TokenForLiveUser
+    deriving (Show, Eq, Generic)
+
+-- | The contents of the Jwt token is an encoding of this structure.
+data Token = Token { _tokenCreds  :: UserCredentials
+                   , _issuedP     :: POSIXTime
+                   , _expiredP    :: POSIXTime
+                   , _jwtAudience :: TokenAudience
+                   }
+    deriving (Show, Eq, Generic)
+
+makeLenses ''Token
+
+instance Aeson.FromJSON Token where
+    parseJSON = Aeson.withObject "web token" $ \o -> do
+        
+        aud :: Text <- o .: "aud"
+        aud' <- case aud of
+                    "mycompany:email" -> pure TokenSentViaEmail
+                    "mycompany:web"   -> pure TokenSentToBrowser
+                    _                 -> panic "Invalid audience for token"
+        
+        Token <$> (UserCredentials <$> o .: "sub" <*> o .: "email" <*> o .: "email_verified")
+              <*> (fromInteger <$> o .: "iat")
+              <*> (fromInteger <$> o .: "exp")
+              <*> pure aud'
+
+instance Aeson.ToJSON Token where
+    toJSON (Token ucreds i e a) = Aeson.object
+        [ "sub"            .= (ucreds^.credId)
+        , "email"          .= (ucreds^.credEmail)
+        , "email_verified" .= (ucreds^.credEmailVerified)
+        , "iat"            .= (round i :: Int64)
+        , "exp"            .= (round e :: Int64)
+        , "aud"            .= case a of
+                                TokenSentViaEmail  -> pack "mycompany:email"
+                                TokenSentToBrowser -> pack "mycompany:web"
+                                TokenForLiveUser   -> pack "mycompany:live"
+        ]
+
+
+newtype UnverifiedJwtToken = UnverifiedJwtToken Text
+  deriving (Show)
+  -- deriving (Show, FromHttpApiData)
+
+type JwtAuthHeader = Header "authorization" UnverifiedJwtToken
+
+type MyAPIWithAuth = JwtAuthHeader :> GargAPI
+
+
+-- Datastorage
+
+--isMemberOfTeam :: UserCredentials -> Team -> Bool
+--user `isMemberOfTeam` team = {- implementation here -}
+--
+--loadTeam :: UserCredentials -> TeamKey -> SqlPersistM Team
+--loadTeam ucreds teamkey = do
+--    mteam <- get teamkey
+--    case mteam of
+--        Nothing -> throwM DocumentNotFound
+--        Just t | ucreds `isMemberOfTeam` t -> return t
+--               | otherwise -> throwM Unauthorized
+
+
+
+createJwt :: TokenAudience -> UserCredentials -> Env -> Servant.Handler UnverifiedJwtToken
+createJwt aud ucreds env = do
+    now <- liftIO getPOSIXTime
+    expire <- pure $ case aud of
+            TokenSentViaEmail -> 15*60 -- 15 minutes
+            TokenForLiveUser  -> 60*60 -- 1 hour
+            _                 -> 60*60
+    let key = env^.settings.jwtSecret
+
+    let token = Token { _tokenCreds = ucreds
+                      , _issuedP = now
+                      , _expiredP = now + expire
+                      , _jwtAudience = aud
+                      }
+    mjwt <- liftIO $ Jose.encode [key] (Jose.JwsEncoding Jose.HS256) (Jose.Claims $ toStrict $ Aeson.encode token)
+    case mjwt of
+        Left _ -> throwError err500 {errBody = "Unable to authenticate"}
+        Right jwt -> pure $ UnverifiedJwtToken $ decodeUtf8 $ Jose.unJwt jwt
+
+
+
+verifyJwt :: UnverifiedJwtToken -> Env -> Servant.Handler Token
+verifyJwt (UnverifiedJwtToken unverifiedText) env = do
+    key <- pure $ env^.settings.jwtSecret
+    mjwtContent <- liftIO $ Jose.decode [key] (Just $ Jose.JwsEncoding Jose.HS256) $ encodeUtf8 unverifiedText
+    jwt <- case mjwtContent of
+            Right (Jose.Jws (_, jwt)) -> pure $ jwt
+            _ -> throwError err401 { errBody = "Invalid javascript web token" }
+
+    case Aeson.eitherDecode (fromStrict jwt) of
+        Left _ -> throwError err401 { errBody = "Unable to parse jwt claims" }
+
+        Right token -> do
+            now <- liftIO getPOSIXTime
+            when (token^.expiredP <= now) $
+                throwError err401 { errBody = "Expired jwt token" }
+            pure token
+
+
+-- | Verify and decode a token
+verifyWebJwt :: Maybe UnverifiedJwtToken -> Env -> Servant.Handler (Maybe Token)
+verifyWebJwt Nothing _ = return Nothing
+verifyWebJwt (Just (UnverifiedJwtToken x)) env = do
+    let unverifiedToken = if "Bearer " `isPrefixOf` x then drop 7 x else x
+    token <- verifyJwt (UnverifiedJwtToken unverifiedToken) env
+    case token^.jwtAudience of
+        TokenSentViaEmail -> throwError err403 { errBody = "Cannot use email token for authentication" }
+        TokenForLiveUser -> pure (Just token)
+        _                -> pure Nothing
+
+
+
 

src/Gargantext/API/Foundation.hs

+{-|
+Module      : Gargantext.API.Foundation
+Description : Handler of the API (Server and Client)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Inspired by : http://blog.wuzzeb.org/full-stack-web-haskell/server.html
+
+-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+{-# LANGUAGE ConstraintKinds             #-}
+{-# LANGUAGE DataKinds                   #-}
+{-# LANGUAGE DeriveFunctor               #-}
+{-# LANGUAGE DeriveGeneric               #-}
+{-# LANGUAGE FlexibleInstances           #-}
+{-# LANGUAGE FlexibleContexts            #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}
+{-# LANGUAGE MultiParamTypeClasses       #-}
+{-# LANGUAGE OverloadedStrings           #-}
+{-# LANGUAGE ScopedTypeVariables         #-}
+{-# LANGUAGE StandaloneDeriving          #-}
+{-# LANGUAGE TemplateHaskell             #-}
+{-# LANGUAGE TypeOperators               #-}
+{-# LANGUAGE AllowAmbiguousTypes         #-}
+
+------------------------------------------------------------------------
+module Gargantext.API.Foundation
+    where
+------------------------------------------------------------------------
+import System.Log.FastLogger
+
+import Control.Applicative
+import Control.Lens
+import Control.Monad
+import Control.Monad.Base
+import Control.Monad.Error.Class
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Resource
+-- import Control.Natural ((:~>))
+
+import Data.Maybe
+
+-- import Database.PostgreSQL.Simple
+import Servant
+
+-- import Gargantext.API
+import Gargantext.API.Auth
+import Gargantext.API.Settings
+import Gargantext.Prelude
+------------------------------------------------------------------------
+------------------------------------------------------------------------
+
+newtype MyServer a = MyServer { myServerM :: 
+                                    ReaderT   (Env, Maybe Token     )
+                                  ( ResourceT (ExceptT ServantErr IO) )
+                                    a
+                              }
+    deriving (Functor, Applicative, Monad, MonadIO)
+
+deriving instance MonadError ServantErr MyServer
+
+instance MonadBase IO MyServer where liftBase = liftIO
+
+instance MonadReader Env MyServer where
+  ask = MyServer (fst <$> ask)
+  local f (MyServer r) = MyServer (local (\(e,t) -> (f e, t)) r)
+
+instance MonadLogger MyServer where
+    monadLoggerLog loc source ll msg = do
+        limit <- view (settings.logLevelLimit)
+        out   <- view logger
+        when (ll >= limit) $
+            liftIO $ pushLogStr out $ defaultLogStr loc source ll $ toLogStr msg
+
+------------------------------------------------------------------------
+getToken :: MyServer (Maybe Token)
+getToken  = MyServer (snd <$> ask)
+
+userRequired :: MyServer UserCredentials
+userRequired  = do
+    mt <- getToken
+    case mt of
+        Nothing -> throwError $ err401 { errBody = "No Authorization header in request" }
+        Just t  -> return $ t^.tokenCreds
+
+runDB :: (a -> b) -> MyServer b
+runDB _ = undefined {- access pool from env, run action -}
+--------------------------------------------------------------------------
+--------------------------------------------------------------------------
+--------------------------------------------------------------------------
+--------------------------------------------------------------------------
+--
+-- | very basic Example for testing purpose
+
+-- type MyAPI         = TeamAPI -- :<|> UserAPI :<|> ...
+type TeamAPI       = GetUserRoute -- :<|>
+type GetUserRoute  = "team"  :> Capture "teamkey" Int :> Get '[JSON] Int
+--type GetTeamRoute     = "team"  :> Capture "teamkey" TeamKey :> Get '[JSON] Team
+
+myServerAPI :: Proxy TeamAPI
+myServerAPI = Proxy
+
+--gargServer' :: ServerT MyAPI MyServer
+--gargServer'  = teamServer
+
+teamServer :: ServerT TeamAPI MyServer
+teamServer  = getTeamR -- :<|> createTeamR :<|> updateTeamR :<|> getAllTeamsR
+
+getTeamR  :: Int -> MyServer Int
+getTeamR _ = do
+    pure 1
+
+---- Note that @type MyAPIWithAuth = JwtAuthHeader :> MyAPI@ so that
+---- @Server MyAPIWithAuth@ expands to @Maybe UnverifiedJwtToken -> Server MyAPI@.
+--myServerWithAuth :: Env -> Server MyAPIWithAuth
+----myServerWithAuth env unverifiedJwt = enter (myServerNat env unverifiedJwt) myServer
+--myServerWithAuth :: forall a. Env -> Maybe UnverifiedJwtToken -> ServerT (MyServer a) Handler
+
+myServerWithAuth :: Env -> Maybe UnverifiedJwtToken -> Int -> Handler Int
+myServerWithAuth env unverifiedJwt = hoistServer myServerAPI (nt env unverifiedJwt) teamServer
+
+-- nt :: Applicative f => Env -> p -> MyServer a -> f (ExceptT ServantErr IO a)
+nt :: Env -> Maybe UnverifiedJwtToken -> MyServer a -> Handler (ExceptT ServantErr IO a)
+nt env _ s = pure $ runResourceT (runReaderT (myServerM s) (env, mtoken'))
+   where
+       mtoken' :: Maybe Token
+       mtoken'  = undefined
+

src/Gargantext/Prelude.hs

@@ -15,17 +15,19 @@ module Gargantext.Prelude
   )
   where
 
-import Protolude ( Bool(True, False), Int, Double, Integer
+import Protolude ( Eq, Bool(True, False), Int, Double, Integer
                  , Fractional, Num, Maybe(Just,Nothing)
                  , Floating, Char, IO
-                 , pure, (<$>), panic
+                 , pure, return, (<$>), panic
                  , Ord, Integral, Foldable, RealFrac, Monad, filter
                  , reverse, map, zip, drop, take, zipWith
-                 , sum, fromIntegral, length, fmap
+                 , sum, fromIntegral, fromInteger, length, fmap
                  , takeWhile, sqrt, undefined, identity
-                 , abs, maximum, minimum, return, snd, truncate
-                 , (+), (*), (/), (-), (.), (>=), ($), (**), (^), (<), (>), (==), (<>)
-                 , (&&), (||), not
+                 , abs, maximum, minimum, truncate
+                 , fst, snd
+                 , (+), (*), (/), (-), (.), (>=), (<=)
+                 , ($), (**), (^), (<), (>), (==), (<>)
+                 , (&&), (||), not, round
                  , toS
                  )