diff options
author | Kjetil Orbekk <kjetil.orbekk@gmail.com> | 2015-10-30 15:15:27 -0400 |
---|---|---|
committer | Kjetil Orbekk <kjetil.orbekk@gmail.com> | 2015-10-30 15:15:27 -0400 |
commit | 3905f84f5b4b2b321cd331c86d0876309f82d48b (patch) | |
tree | f8c65af081f86269f6899958a2a55a917048b511 /src/Authentication.hs | |
parent | 4036c1047af89482db56d04a250f6c9416d9b22f (diff) |
Include code review changes from Erlend.
Diffstat (limited to 'src/Authentication.hs')
-rw-r--r-- | src/Authentication.hs | 46 |
1 files changed, 20 insertions, 26 deletions
diff --git a/src/Authentication.hs b/src/Authentication.hs index a0d3d8c..35cbf23 100644 --- a/src/Authentication.hs +++ b/src/Authentication.hs @@ -1,9 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Authentication (User, queryUser, isAuthenticated) where import Data.Aeson @@ -15,6 +16,7 @@ import Data.ByteString.Lazy.Char8 (unpack) import Control.Exception import Control.Monad.Trans import Control.Monad.Trans.Either +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Control.Concurrent.MVar makeUrl = ("https://www.googleapis.com/oauth2/v3/tokeninfo?id_token="++) @@ -28,29 +30,21 @@ data User = User instance FromJSON User queryUser :: Token -> IO (Maybe User) -queryUser token = (queryUser' token) `catch` \e -> do - print (e :: HttpException) - return Nothing - -queryUser' token = do - response <- simpleHttp (makeUrl token) - return (decode response) +queryUser token = runEitherT (lift queryUser') >>= \case + Left e -> print (e :: HttpException) >> return Nothing + Right response -> return response + where queryUser' = decode <$> simpleHttp (makeUrl token) isAuthenticated :: [String] -> [String] -> MVar [Token] -> Token -> IO Bool -isAuthenticated clientIds allowedUsers tokenCache token = runEitherT runner >>= return . fromEither - where runner :: EitherT Bool IO Bool - runner = do - ts <- lift $ readMVar tokenCache - _ <- leftIf (token `elem` ts) True - user <- lift $ queryUser token - email' <- return $ fromMaybe "" (user >>= return . email) - aud' <- return $ fromMaybe "" (user >>= return . aud) - liftIO $ putStrLn $ "Trying to authenticate user: " ++ show user - _ <- leftIf (not (email' `elem` allowedUsers)) False - _ <- leftIf (not (aud' `elem` clientIds)) False - tokens <- lift $ takeMVar tokenCache - lift $ putMVar tokenCache (token:tokens) - return True - - leftIf True x = left x - leftIf False x = right x +isAuthenticated clientIds allowedUsers tokenCache token = do + ts <- readMVar tokenCache + if token `elem` ts + then return True + else isJust <$> isValidUser + where isValidUser = runMaybeT $ do + Just user <- lift $ queryUser token + True <- return $ email user `elem` allowedUsers + True <- return $ aud user `elem` clientIds + tokens <- lift $ takeMVar tokenCache + lift $ putMVar tokenCache (token:tokens) + return () |