module Network.AWS.Auth
(
accessKey
, secretKey
, fromKeys
, fromSession
, Credentials (..)
, getAuth
) where
import Control.Applicative
import Control.Concurrent
import Control.Monad.Except
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.IORef
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Time
import Network.AWS.Data
import Network.AWS.EC2.Metadata
import Network.AWS.Types
import Network.HTTP.Client
import System.Environment
import System.Mem.Weak
accessKey :: Text
accessKey = "AWS_ACCESS_KEY"
secretKey :: Text
secretKey = "AWS_SECRET_KEY"
fromKeys :: AccessKey -> SecretKey -> Auth
fromKeys a s = Auth (AuthEnv a s Nothing Nothing)
fromSession :: AccessKey -> SecretKey -> SecurityToken -> Auth
fromSession a s t = Auth (AuthEnv a s (Just t) Nothing)
data Credentials
= FromKeys AccessKey SecretKey
| FromSession AccessKey SecretKey SecurityToken
| FromProfile Text
| FromEnv Text Text
| Discover
deriving (Eq)
instance ToText Credentials where
toText = \case
FromKeys a _ -> "FromKeys " <> toText a <> " ****"
FromSession a _ _ -> "FromSession " <> toText a <> " **** ****"
FromProfile n -> "FromProfile " <> n
FromEnv a s -> "FromEnv " <> a <> " " <> s
Discover -> "Discover"
instance Show Credentials where
show = showText
getAuth :: (Functor m, MonadIO m)
=> Manager
-> Credentials
-> ExceptT String m Auth
getAuth m = \case
FromKeys a s -> return (fromKeys a s)
FromSession a s t -> return (fromSession a s t)
FromProfile n -> show `withExceptT` fromProfileName m n
FromEnv a s -> fromEnvVars a s
Discover -> fromEnv `catchError` const (iam `catchError` const err)
where
iam = show `withExceptT` fromProfile m
err = throwError "Unable to read environment variables or IAM profile."
fromEnv :: (Functor m, MonadIO m) => ExceptT String m Auth
fromEnv = fromEnvVars accessKey secretKey
fromEnvVars :: (Functor m, MonadIO m) => Text -> Text -> ExceptT String m Auth
fromEnvVars a s = fmap Auth $ AuthEnv
<$> (AccessKey <$> key a)
<*> (SecretKey <$> key s)
<*> pure Nothing
<*> pure Nothing
where
key (Text.unpack -> k) = ExceptT $ do
m <- liftIO (lookupEnv k)
return $
maybe (Left $ "Unable to read ENV variable: " ++ k)
(Right . BS.pack)
m
fromProfile :: MonadIO m => Manager -> ExceptT HttpException m Auth
fromProfile m = do
!ls <- BS.lines `liftM` metadata m (IAM $ SecurityCredentials Nothing)
case ls of
(x:_) -> fromProfileName m (Text.decodeUtf8 x)
_ -> throwError $
HttpParserException "Unable to get default IAM Profile from EC2 metadata"
fromProfileName :: MonadIO m
=> Manager
-> Text
-> ExceptT HttpException m Auth
fromProfileName m name = auth >>= start
where
auth :: MonadIO m => ExceptT HttpException m AuthEnv
auth = do
!lbs <- LBS.fromStrict `liftM` metadata m
(IAM . SecurityCredentials $ Just name)
either (throwError . HttpParserException)
return
(Aeson.eitherDecode lbs)
start !a = ExceptT . liftM Right . liftIO $
case _authExpiry a of
Nothing -> return (Auth a)
Just x -> do
r <- newIORef a
p <- myThreadId
s <- timer r p x
return (Ref s r)
timer r p x = forkIO $ do
s <- myThreadId
w <- mkWeakIORef r (killThread s)
loop w p x
loop w p x = do
diff x <$> getCurrentTime >>= threadDelay
ea <- runExceptT auth
case ea of
Left e -> throwTo p e
Right !a -> do
mr <- deRefWeak w
case mr of
Nothing -> return ()
Just r -> do
atomicWriteIORef r a
maybe (return ()) (loop w p) (_authExpiry a)
diff x y = (* 1000000) $
let n = truncate (diffUTCTime x y) 60
in if n > 0 then n else 1