module Network.AWS.Auth
(
getAuth
, Credentials (..)
, Auth
, envAccessKey
, envSecretKey
, envSessionToken
, credAccessKey
, credSecretKey
, credSessionToken
, credProfile
, credFile
, fromKeys
, fromSession
, fromEnv
, fromEnvKeys
, fromFile
, fromFilePath
, fromProfile
, fromProfileName
, AccessKey (..)
, SecretKey (..)
, SessionToken (..)
, AsAuthError (..)
, AuthError (..)
) where
import Control.Applicative
import Control.Concurrent
import Control.Exception.Lens
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy.Char8 as LBS8
import Data.Char (isSpace)
import qualified Data.Ini as INI
import Data.IORef
import Data.Monoid
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Time (diffUTCTime, getCurrentTime)
import Network.AWS.Data.Log
import Network.AWS.EC2.Metadata
import Network.AWS.Prelude
import Network.AWS.Types
import Network.HTTP.Conduit
import System.Directory (doesFileExist, getHomeDirectory)
import System.Environment
import System.Mem.Weak
import Prelude
envAccessKey :: Text
envAccessKey = "AWS_ACCESS_KEY_ID"
envSecretKey :: Text
envSecretKey = "AWS_SECRET_ACCESS_KEY"
envSessionToken :: Text
envSessionToken = "AWS_SESSION_TOKEN"
credAccessKey :: Text
credAccessKey = "aws_access_key_id"
credSecretKey :: Text
credSecretKey = "aws_secret_access_key"
credSessionToken :: Text
credSessionToken = "aws_session_token"
credProfile :: Text
credProfile = "default"
credFile :: (MonadCatch m, MonadIO m) => m FilePath
credFile = catching_ _IOException dir err
where
dir = (++ p) `liftM` liftIO getHomeDirectory
err = throwM $ MissingFileError ("$HOME" ++ p)
p = "/.aws/credentials"
fromKeys :: AccessKey -> SecretKey -> Auth
fromKeys a s = Auth (AuthEnv a s Nothing Nothing)
fromSession :: AccessKey -> SecretKey -> SessionToken -> Auth
fromSession a s t = Auth (AuthEnv a s (Just t) Nothing)
data Credentials
= FromKeys AccessKey SecretKey
| FromSession AccessKey SecretKey SessionToken
| FromEnv Text Text (Maybe Text)
| FromProfile Text
| FromFile Text FilePath
| Discover
deriving (Eq)
instance ToLog Credentials where
build = \case
FromKeys a _ -> "FromKeys " <> build a <> " ****"
FromSession a _ _ -> "FromSession " <> build a <> " **** ****"
FromEnv a s t -> "FromEnv " <> build a <> " " <> build s <> " " <> m t
FromProfile n -> "FromProfile " <> build n
FromFile n f -> "FromFile " <> build n <> " " <> build f
Discover -> "Discover"
where
m (Just x) = "(Just " <> build x <> ")"
m Nothing = "Nothing"
instance Show Credentials where
show = BS8.unpack . toBS . build
data AuthError
= RetrievalError HttpException
| MissingEnvError Text
| MissingFileError FilePath
| InvalidFileError Text
| InvalidIAMError Text
deriving (Show, Typeable)
instance Exception AuthError
instance ToLog AuthError where
build = \case
RetrievalError e -> build e
MissingEnvError e -> "[MissingEnvError] { message = " <> build e <> "}"
MissingFileError f -> "[MissingFileError] { path = " <> build f <> "}"
InvalidFileError e -> "[InvalidFileError] { message = " <> build e <> "}"
InvalidIAMError e -> "[InvalidIAMError] { message = " <> build e <> "}"
class AsAuthError a where
_AuthError :: Prism' a AuthError
_RetrievalError :: Prism' a HttpException
_MissingEnvError :: Prism' a Text
_MissingFileError :: Prism' a FilePath
_InvalidFileError :: Prism' a Text
_InvalidIAMError :: Prism' a Text
_RetrievalError = _AuthError . _RetrievalError
_MissingEnvError = _AuthError . _MissingEnvError
_MissingFileError = _AuthError . _MissingFileError
_InvalidFileError = _AuthError . _InvalidFileError
_InvalidIAMError = _AuthError . _InvalidIAMError
instance AsAuthError SomeException where
_AuthError = exception
instance AsAuthError AuthError where
_AuthError = id
_RetrievalError = prism RetrievalError $ \case
RetrievalError e -> Right e
x -> Left x
_MissingEnvError = prism MissingEnvError $ \case
MissingEnvError e -> Right e
x -> Left x
_MissingFileError = prism MissingFileError $ \case
MissingFileError f -> Right f
x -> Left x
_InvalidFileError = prism InvalidFileError $ \case
InvalidFileError e -> Right e
x -> Left x
_InvalidIAMError = prism InvalidIAMError $ \case
InvalidIAMError e -> Right e
x -> Left x
getAuth :: (Applicative m, MonadIO m, MonadCatch m)
=> Manager
-> Credentials
-> m Auth
getAuth m = \case
FromKeys a s -> return (fromKeys a s)
FromSession a s t -> return (fromSession a s t)
FromEnv a s t -> fromEnvKeys a s t
FromProfile n -> fromProfileName m n
FromFile n f -> fromFilePath n f
Discover ->
catching_ _MissingEnvError fromEnv $
catching _MissingFileError fromFile $ \f -> do
p <- isEC2 m
unless p $
throwingM _MissingFileError f
fromProfile m
fromEnv :: (Applicative m, MonadIO m, MonadThrow m) => m Auth
fromEnv = fromEnvKeys envAccessKey envSecretKey (Just envSessionToken)
fromEnvKeys :: (Applicative m, MonadIO m, MonadThrow m)
=> Text
-> Text
-> Maybe Text
-> m Auth
fromEnvKeys a s t = fmap Auth $ AuthEnv
<$> (req a <&> AccessKey)
<*> (req s <&> SecretKey)
<*> (opt t <&> fmap SessionToken)
<*> pure Nothing
where
req k = do
m <- opt (Just k)
maybe (throwM . MissingEnvError $ "Unable to read ENV variable: " <> k)
return
m
opt Nothing = return Nothing
opt (Just k) = fmap BS8.pack <$> liftIO (lookupEnv (Text.unpack k))
fromFile :: (Applicative m, MonadIO m, MonadCatch m) => m Auth
fromFile = credFile >>= fromFilePath credProfile
fromFilePath :: (Applicative m, MonadIO m, MonadCatch m)
=> Text
-> FilePath
-> m Auth
fromFilePath n f = do
p <- liftIO (doesFileExist f)
unless p $ throwM (MissingFileError f)
i <- liftIO (INI.readIniFile f) >>= either (invalidErr Nothing) return
fmap Auth $ AuthEnv
<$> (req credAccessKey i <&> AccessKey)
<*> (req credSecretKey i <&> SecretKey)
<*> (opt credSessionToken i <&> fmap SessionToken)
<*> pure Nothing
where
req k i =
case INI.lookupValue n k i of
Left e -> invalidErr (Just k) e
Right x
| blank x -> invalidErr (Just k) "cannot be a blank string."
| otherwise -> return (Text.encodeUtf8 x)
opt k i = return $
case INI.lookupValue n k i of
Left _ -> Nothing
Right x -> Just (Text.encodeUtf8 x)
invalidErr Nothing e = throwM $ InvalidFileError (Text.pack e)
invalidErr (Just k) e = throwM $ InvalidFileError
(Text.pack f <> ", key " <> k <> " " <> Text.pack e)
blank x = Text.null x || Text.all isSpace x
fromProfile :: (MonadIO m, MonadCatch m) => Manager -> m Auth
fromProfile m = do
ls <- try $ metadata m (IAM (SecurityCredentials Nothing))
case BS8.lines `liftM` ls of
Right (x:_) -> fromProfileName m (Text.decodeUtf8 x)
Left e -> throwM (RetrievalError e)
_ -> throwM $
InvalidIAMError "Unable to get default IAM Profile from EC2 metadata"
fromProfileName :: (MonadIO m, MonadCatch m) => Manager -> Text -> m Auth
fromProfileName m name = auth >>= start
where
auth :: (MonadIO m, MonadCatch m) => m AuthEnv
auth = do
bs <- try $ metadata m (IAM . SecurityCredentials $ Just name)
case bs of
Left e -> throwM (RetrievalError e)
Right x ->
either (throwM . invalidErr)
return
(eitherDecode' (LBS8.fromStrict x))
invalidErr = InvalidIAMError
. mappend ("Error parsing IAM profile '" <> name <> "' ")
. Text.pack
start :: MonadIO m => AuthEnv -> m Auth
start !a = 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 :: IORef AuthEnv -> ThreadId -> UTCTime -> IO ThreadId
timer !r !p !x = forkIO $ do
s <- myThreadId
w <- mkWeakIORef r (killThread s)
loop w p x
loop :: Weak (IORef AuthEnv) -> ThreadId -> UTCTime -> IO ()
loop w !p !x = do
diff x <$> getCurrentTime >>= threadDelay
ea <- try auth
case ea of
Left e -> throwTo p (RetrievalError 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) $ if n > 0 then n else 1
where
!n = truncate (diffUTCTime x y) 60