{-# LANGUAGE Strict #-}

-- |
-- Module      : Amazonka.Auth.Background
-- Copyright   : (c) 2013-2023 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
--
-- Helpers for authentication schemes which refresh themselves in the
-- background.
module Amazonka.Auth.Background where

import Amazonka.Auth.Exception
import Amazonka.Data
import Amazonka.Prelude
import Amazonka.Types
import Control.Concurrent (ThreadId)
import qualified Control.Concurrent as Concurrent
import qualified Control.Exception as Exception
import Data.IORef (IORef)
import qualified Data.IORef as IORef
import qualified Data.Time as Time
import System.Mem.Weak (Weak)
import qualified System.Mem.Weak as Weak

-- | Implements the background fetching behavior used by (among others)
-- 'fromProfileName' and 'fromContainer'. Given an 'IO' action that produces an
-- 'AuthEnv', this spawns a thread that mutates the 'IORef' returned in the
-- resulting 'Auth' to keep the temporary credentials up to date.
fetchAuthInBackground :: IO AuthEnv -> IO Auth
fetchAuthInBackground :: IO AuthEnv -> IO Auth
fetchAuthInBackground IO AuthEnv
menv =
  IO AuthEnv
menv IO AuthEnv -> (AuthEnv -> IO Auth) -> IO Auth
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \AuthEnv
env -> IO Auth -> IO Auth
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Auth -> IO Auth) -> IO Auth -> IO Auth
forall a b. (a -> b) -> a -> b
$
    case AuthEnv -> Maybe ISO8601
expiration AuthEnv
env of
      Maybe ISO8601
Nothing -> Auth -> IO Auth
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthEnv -> Auth
Auth AuthEnv
env)
      Just ISO8601
x -> do
        r <- AuthEnv -> IO (IORef AuthEnv)
forall a. a -> IO (IORef a)
IORef.newIORef AuthEnv
env
        p <- Concurrent.myThreadId
        s <- timer menv r p x

        pure (Ref s r)
  where
    timer :: IO AuthEnv -> IORef AuthEnv -> ThreadId -> ISO8601 -> IO ThreadId
    timer :: IO AuthEnv -> IORef AuthEnv -> ThreadId -> ISO8601 -> IO ThreadId
timer IO AuthEnv
ma IORef AuthEnv
r ThreadId
p ISO8601
x =
      IO () -> IO ThreadId
Concurrent.forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        s <- IO ThreadId
Concurrent.myThreadId
        w <- IORef.mkWeakIORef r (Concurrent.killThread s)

        loop ma w p x

    loop :: IO AuthEnv -> Weak (IORef AuthEnv) -> ThreadId -> ISO8601 -> IO ()
    loop :: IO AuthEnv -> Weak (IORef AuthEnv) -> ThreadId -> ISO8601 -> IO ()
loop IO AuthEnv
ma Weak (IORef AuthEnv)
w ThreadId
p ISO8601
x = do
      untilExpiry <- ISO8601 -> UTCTime -> Int
forall {a} {a :: Format}. Integral a => Time a -> UTCTime -> a
diff ISO8601
x (UTCTime -> Int) -> IO UTCTime -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
Time.getCurrentTime
      -- Refresh the token within 5 minutes of expiry, or half its lifetime if
      -- sooner than that. This is to account for execution time of the refresh action.
      let fiveMinutes = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
      Concurrent.threadDelay $
        if untilExpiry > fiveMinutes
          then untilExpiry - fiveMinutes
          else untilExpiry `div` 2

      env <- Exception.try @SomeException ma
      case env of
        Left SomeException
e -> ThreadId -> AuthError -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
Exception.throwTo ThreadId
p (AuthError -> IO ()) -> AuthError -> IO ()
forall a b. (a -> b) -> a -> b
$ case SomeException -> Maybe AuthError
forall e. Exception e => SomeException -> Maybe e
Exception.fromException SomeException
e of
          Just (RetrievalError HttpException
e') -> HttpException -> AuthError
RetrievalError HttpException
e'
          Just (AuthServiceError ServiceError
e') -> ServiceError -> AuthError
AuthServiceError ServiceError
e'
          Maybe AuthError
_ -> SomeException -> AuthError
OtherAuthError SomeException
e
        Right AuthEnv
a -> do
          mr <- Weak (IORef AuthEnv) -> IO (Maybe (IORef AuthEnv))
forall v. Weak v -> IO (Maybe v)
Weak.deRefWeak Weak (IORef AuthEnv)
w
          case mr of
            Maybe (IORef AuthEnv)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just IORef AuthEnv
r -> do
              IORef AuthEnv -> AuthEnv -> IO ()
forall a. IORef a -> a -> IO ()
IORef.atomicWriteIORef IORef AuthEnv
r AuthEnv
a
              IO () -> (ISO8601 -> IO ()) -> Maybe ISO8601 -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO AuthEnv -> Weak (IORef AuthEnv) -> ThreadId -> ISO8601 -> IO ()
loop IO AuthEnv
ma Weak (IORef AuthEnv)
w ThreadId
p) (AuthEnv -> Maybe ISO8601
expiration AuthEnv
a)

    diff :: Time a -> UTCTime -> a
diff (Time UTCTime
x) UTCTime
y = a -> a
picoToMicro (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 then a
n else a
1
      where
        n :: a
n = NominalDiffTime -> a
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (UTCTime -> UTCTime -> NominalDiffTime
Time.diffUTCTime UTCTime
x UTCTime
y) a -> a -> a
forall a. Num a => a -> a -> a
- a
60
        picoToMicro :: a -> a
picoToMicro = (a -> a -> a
forall a. Num a => a -> a -> a
* a
1000000)