{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
module Kubernetes.Client.Auth.TokenFile where

import           Control.Concurrent.STM
import           Data.Function                  ( (&) )
import           Data.Monoid                    ( (<>) )
import           Data.Text                      ( Text )
import           Data.Time.Clock
import           Kubernetes.Client.Auth.Internal.Types
import           Kubernetes.OpenAPI.Core
import           Kubernetes.Client.KubeConfig
                                         hiding ( token )
import qualified Data.Text                     as T
import qualified Data.Text.IO                  as T
import qualified Lens.Micro                    as L

data TokenFileAuth = TokenFileAuth { TokenFileAuth -> TVar (Maybe Text)
token :: TVar(Maybe Text)
                                   , TokenFileAuth -> TVar (Maybe UTCTime)
expiry :: TVar(Maybe UTCTime)
                                   , TokenFileAuth -> FilePath
file :: FilePath
                                   , TokenFileAuth -> NominalDiffTime
period :: NominalDiffTime
                                   }

instance AuthMethod TokenFileAuth where
  applyAuthMethod :: KubernetesClientConfig
-> TokenFileAuth
-> KubernetesRequest req contentType res accept
-> IO (KubernetesRequest req contentType res accept)
applyAuthMethod KubernetesClientConfig
_ TokenFileAuth
tokenFile KubernetesRequest req contentType res accept
req = do
    Text
t <- TokenFileAuth -> IO Text
getToken TokenFileAuth
tokenFile
    KubernetesRequest req contentType res accept
-> IO (KubernetesRequest req contentType res accept)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (KubernetesRequest req contentType res accept
 -> IO (KubernetesRequest req contentType res accept))
-> KubernetesRequest req contentType res accept
-> IO (KubernetesRequest req contentType res accept)
forall a b. (a -> b) -> a -> b
$           KubernetesRequest req contentType res accept
req
      KubernetesRequest req contentType res accept
-> [Header] -> KubernetesRequest req contentType res accept
forall req contentType res accept.
KubernetesRequest req contentType res accept
-> [Header] -> KubernetesRequest req contentType res accept
`setHeader` (HeaderName, Text) -> [Header]
forall a. ToHttpApiData a => (HeaderName, a) -> [Header]
toHeader (HeaderName
"authorization", Text
"Bearer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t)
      KubernetesRequest req contentType res accept
-> (KubernetesRequest req contentType res accept
    -> KubernetesRequest req contentType res accept)
-> KubernetesRequest req contentType res accept
forall a b. a -> (a -> b) -> b
&           ASetter
  (KubernetesRequest req contentType res accept)
  (KubernetesRequest req contentType res accept)
  [TypeRep]
  [TypeRep]
-> [TypeRep]
-> KubernetesRequest req contentType res accept
-> KubernetesRequest req contentType res accept
forall s t a b. ASetter s t a b -> b -> s -> t
L.set ASetter
  (KubernetesRequest req contentType res accept)
  (KubernetesRequest req contentType res accept)
  [TypeRep]
  [TypeRep]
forall req contentType res accept.
Lens_' (KubernetesRequest req contentType res accept) [TypeRep]
rAuthTypesL []

-- |Detects if token-file is specified in AuthConfig.
tokenFileAuth :: DetectAuth
tokenFileAuth :: DetectAuth
tokenFileAuth AuthInfo
auth (ClientParams
tlsParams, KubernetesClientConfig
cfg) = do
  FilePath
file <- AuthInfo -> Maybe FilePath
tokenFile AuthInfo
auth
  IO (ClientParams, KubernetesClientConfig)
-> Maybe (IO (ClientParams, KubernetesClientConfig))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (ClientParams, KubernetesClientConfig)
 -> Maybe (IO (ClientParams, KubernetesClientConfig)))
-> IO (ClientParams, KubernetesClientConfig)
-> Maybe (IO (ClientParams, KubernetesClientConfig))
forall a b. (a -> b) -> a -> b
$ do
    KubernetesClientConfig
c <- FilePath -> KubernetesClientConfig -> IO KubernetesClientConfig
setTokenFileAuth FilePath
file KubernetesClientConfig
cfg
    (ClientParams, KubernetesClientConfig)
-> IO (ClientParams, KubernetesClientConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientParams
tlsParams, KubernetesClientConfig
c)

-- |Configures the 'KubernetesClientConfig' to use TokenFile authentication.
setTokenFileAuth
  :: FilePath -> KubernetesClientConfig -> IO KubernetesClientConfig
setTokenFileAuth :: FilePath -> KubernetesClientConfig -> IO KubernetesClientConfig
setTokenFileAuth FilePath
f KubernetesClientConfig
kcfg = STM KubernetesClientConfig -> IO KubernetesClientConfig
forall a. STM a -> IO a
atomically (STM KubernetesClientConfig -> IO KubernetesClientConfig)
-> STM KubernetesClientConfig -> IO KubernetesClientConfig
forall a b. (a -> b) -> a -> b
$ do
  TVar (Maybe Text)
t <- Maybe Text -> STM (TVar (Maybe Text))
forall a. a -> STM (TVar a)
newTVar (Maybe Text
forall a. Maybe a
Nothing :: Maybe Text)
  TVar (Maybe UTCTime)
e <- Maybe UTCTime -> STM (TVar (Maybe UTCTime))
forall a. a -> STM (TVar a)
newTVar (Maybe UTCTime
forall a. Maybe a
Nothing :: Maybe UTCTime)
  KubernetesClientConfig -> STM KubernetesClientConfig
forall (m :: * -> *) a. Monad m => a -> m a
return KubernetesClientConfig
kcfg
    { configAuthMethods :: [AnyAuthMethod]
configAuthMethods =
      [ TokenFileAuth -> AnyAuthMethod
forall a. AuthMethod a => a -> AnyAuthMethod
AnyAuthMethod
          (TokenFileAuth :: TVar (Maybe Text)
-> TVar (Maybe UTCTime)
-> FilePath
-> NominalDiffTime
-> TokenFileAuth
TokenFileAuth { token :: TVar (Maybe Text)
token = TVar (Maybe Text)
t, expiry :: TVar (Maybe UTCTime)
expiry = TVar (Maybe UTCTime)
e, file :: FilePath
file = FilePath
f, period :: NominalDiffTime
period = NominalDiffTime
60 })
      ]
    }

getToken :: TokenFileAuth -> IO Text
getToken :: TokenFileAuth -> IO Text
getToken TokenFileAuth
auth = TokenFileAuth -> IO (Maybe Text)
getCurrentToken TokenFileAuth
auth IO (Maybe Text) -> (Maybe Text -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Text -> (Text -> IO Text) -> Maybe Text -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TokenFileAuth -> IO Text
reloadToken TokenFileAuth
auth) Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return

getCurrentToken :: TokenFileAuth -> IO (Maybe Text)
getCurrentToken :: TokenFileAuth -> IO (Maybe Text)
getCurrentToken TokenFileAuth { TVar (Maybe Text)
token :: TVar (Maybe Text)
token :: TokenFileAuth -> TVar (Maybe Text)
token, TVar (Maybe UTCTime)
expiry :: TVar (Maybe UTCTime)
expiry :: TokenFileAuth -> TVar (Maybe UTCTime)
expiry } = do
  UTCTime
now         <- IO UTCTime
getCurrentTime
  Maybe UTCTime
maybeExpiry <- TVar (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe UTCTime)
expiry
  Maybe Text
maybeToken  <- TVar (Maybe Text) -> IO (Maybe Text)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe Text)
token
  Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
e <- Maybe UTCTime
maybeExpiry
    if UTCTime
e UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
now then Maybe Text
maybeToken else Maybe Text
forall a. Maybe a
Nothing

reloadToken :: TokenFileAuth -> IO Text
reloadToken :: TokenFileAuth -> IO Text
reloadToken TokenFileAuth { TVar (Maybe Text)
token :: TVar (Maybe Text)
token :: TokenFileAuth -> TVar (Maybe Text)
token, TVar (Maybe UTCTime)
expiry :: TVar (Maybe UTCTime)
expiry :: TokenFileAuth -> TVar (Maybe UTCTime)
expiry, FilePath
file :: FilePath
file :: TokenFileAuth -> FilePath
file, NominalDiffTime
period :: NominalDiffTime
period :: TokenFileAuth -> NominalDiffTime
period } = do
  Text
content <- FilePath -> IO Text
T.readFile FilePath
file
  let t :: Text
t = Text -> Text
T.strip Text
content
  UTCTime
now <- IO UTCTime
getCurrentTime
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TVar (Maybe Text) -> Maybe Text -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Text)
token  (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t)
    TVar (Maybe UTCTime) -> Maybe UTCTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe UTCTime)
expiry (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
period UTCTime
now))
  Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t