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 ()