content: {-
    Copyright 2020 The CodeWorld Authors. All rights reserved.
  
    Licensed under the Apache License, Version 2.0 (the "License");
    you may not use this file except in compliance with the License.
    You may obtain a copy of the License at
  
        http://www.apache.org/licenses/LICENSE-2.0
  
    Unless required by applicable law or agreed to in writing, software
    distributed under the License is distributed on an "AS IS" BASIS,
    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
    See the License for the specific language governing permissions and
    limitations under the License.
  -}
  {-# LANGUAGE OverloadedStrings #-}
  
  -- |
  -- Snap routes and functions for default Google authentication method
  module CodeWorld.Auth.GoogleAuth
    ( AuthConfig,
      authRoutes,
      authenticated,
      configureAuth,
      optionallyAuthenticated,
    )
  where
  
  import CodeWorld.Account (UserId (..))
  import CodeWorld.Auth.Http
  import CodeWorld.Auth.Types
  import Control.Monad (mzero, when)
  import Control.Monad.IO.Class (liftIO)
  import Data.Aeson
    ( (.:),
      FromJSON,
      Value (..),
      decode,
      parseJSON,
    )
  import Data.ByteString (ByteString)
  import qualified Data.ByteString.Char8 as Char8 (unpack)
  import Data.Text (Text)
  import qualified Data.Text as Text (strip)
  import qualified Data.Text.IO as Text (readFile)
  import Network.HTTP.Conduit (simpleHttp)
  import Snap.Core (Snap, finishWith, getParam, pass)
  import System.Directory (doesFileExist)
  import System.FilePath ((</>))
  
  newtype ClientId = ClientId Text deriving (Eq)
  
  data AuthConfig = AuthConfig ClientId
  
  data User = User UserId Text
  
  instance FromJSON User where
    parseJSON (Object v) = User <$> (UserId <$> v .: "user_id") <*> v .: "audience"
    parseJSON _ = mzero
  
  configureAuth :: FilePath -> IO (Maybe AuthConfig)
  configureAuth appDir = do
    let clientIdPath = appDir </> "web/clientId.txt"
    clientIdPathExists <- doesFileExist clientIdPath
    case clientIdPathExists of
      False -> do
        putStrLn $
          "Client ID file not found at "
            ++ clientIdPath
            ++ ": skipping configuration of Google authentication"
        pure Nothing
      True -> do
        clientIdContent <- Text.readFile "web/clientId.txt"
        let clientId = ClientId $ Text.strip clientIdContent
        pure $ Just (AuthConfig clientId)
  
  authRoutes :: AuthConfig -> [Route]
  authRoutes _ = []
  
  authenticated :: (UserId -> Snap ()) -> AuthConfig -> Snap ()
  authenticated handler authConfig = do
    mbIdToken <- getParam "id_token"
    case mbIdToken of
      Nothing -> finishWith forbidden403
      Just idToken -> do
        userId <- authenticatedHelper authConfig idToken
        handler userId
  
  optionallyAuthenticated :: (Maybe UserId -> Snap ()) -> AuthConfig -> Snap ()
  optionallyAuthenticated handler authConfig = do
    mbIdToken <- getParam "id_token"
    case mbIdToken of
      Nothing -> handler Nothing
      Just idToken -> do
        userId <- authenticatedHelper authConfig idToken
        handler (Just userId)
  
  -- | Helper for authenticated API calls: retrieves the user for the current
  --  request. The request should have an @id_token@ parameter with an ID token
  --  retrieved from the Google authentication API. The user is returned if the
  --  ID token is valid.
  authenticatedHelper :: AuthConfig -> ByteString -> Snap UserId
  authenticatedHelper (AuthConfig clientId) idToken = do
    let url = "https://www.googleapis.com/oauth2/v1/tokeninfo?id_token=" ++ Char8.unpack idToken
    result <- fmap decode $ liftIO $ simpleHttp url
    case result of
      Nothing -> pass
      Just (User userId audience) -> do
        when (clientId /= ClientId audience) pass
        return userId
  