Include code review changes from Erlend.

2 files changed, 30 insertions, 30 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 ()
diff --git a/src/Main.hs b/src/Main.hs
index 46b6108..5bf7138 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -54,13 +54,16 @@ type PhotoApi =
            :> AuthenticationHeader
            :> ReqBody '[JSON] RenameRequest
            :> Post '[JSON] (Either RenameError ())
+  :<|> "quit" :> Get '[JSON] ()
 
 type Token = String
 
+{-# NOINLINE cache #-}
+cache = unsafePerformIO (newMVar [])
+
 isAuthenticated = Authentication.isAuthenticated clientIds users cache
     where clientIds = splitOn "," flags_client_ids
           users = splitOn "," flags_allowed_users
-          cache = unsafePerformIO (newMVar [])
 
 config = Config
   { pendingPath = flags_pending_path
@@ -68,20 +71,23 @@ config = Config
   }
 
 checkAuthenticated :: Maybe Token -> EitherT ServantErr IO ()
-checkAuthenticated (Just token) = liftIO (isAuthenticated token) >>= \case
-  True  -> return ()
-  False -> left err503 { errBody = "Not authenticated" }
+checkAuthenticated (Just token) = do
+  authenticated <- liftIO (isAuthenticated token)
+  unless authenticated $ left err503 { errBody = "Not authenticated" }
 checkAuthenticated Nothing = left err503 { errBody = "Missing token" }
 
 server :: Server PhotoApi
 server = albums
     :<|> rename
+    :<|> quit
   where albums token = checkAuthenticated token >> liftIO (getAlbums config)
 
         rename token (RenameRequest from to) = do
           _ <- checkAuthenticated token
           liftIO $ runEitherT (renameAlbum config from to)
 
+        quit = liftIO exitFailure
+
 photoApi :: Proxy PhotoApi
 photoApi = Proxy
 app = logStdoutDev $ serve photoApi server