{-# LANGUAGE OverloadedStrings #-}
module Network.Google.Compute.Metadata
(
checkGCEVar
, isGCE
, getProjectAttribute
, getSSHKeys
, getNumericProjectId
, getProjectId
, getInstanceAttribute
, getDescription
, getHostname
, getInstanceId
, getMachineType
, getTags
, getZone
, metadataFlavorHeader
, metadataFlavorDesired
, metadataRequest
, getMetadata
) where
import Control.Exception (throwIO)
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO (..))
import Data.Aeson (eitherDecode')
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Char (toLower)
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Encoding as LText
import Network.Google.Prelude (Text, (<>))
import Network.HTTP.Client (HttpException (..),
HttpExceptionContent (..), Manager)
import qualified Network.HTTP.Client as Client
import Network.HTTP.Types (HeaderName)
import System.Environment (lookupEnv)
checkGCEVar :: String
checkGCEVar = "NO_GCE_CHECK"
metadataFlavorHeader :: HeaderName
metadataFlavorHeader = "Metadata-Flavor"
metadataFlavorDesired :: ByteString
metadataFlavorDesired = "Google"
isGCE :: MonadIO m => Manager -> m Bool
isGCE m = liftIO $ do
p <- check <$> lookupEnv checkGCEVar
if p
then (success <$> Client.httpLbs rq m) `catch` failure
else pure False
where
check Nothing = True
check (Just x) = map toLower x `notElem` ["1", "true", "yes", "on"]
success rs =
fromEnum (Client.responseStatus rs) == 200
&& (lookup metadataFlavorHeader (Client.responseHeaders rs)
== Just metadataFlavorDesired)
failure :: HttpException -> IO Bool
failure = const (pure False)
rq = metadataRequest
{ Client.responseTimeout = Client.responseTimeoutMicro 1000000
}
getProjectAttribute :: MonadIO m => Text -> Manager -> m (Maybe LBS.ByteString)
getProjectAttribute k =
getMetadataMaybe ("project/attributes/" <> Text.encodeUtf8 k)
getSSHKeys :: MonadIO m => Manager -> m [Text]
getSSHKeys m = do
mx <- getMetadataMaybe "project/attributes/sshKeys" m
case mx of
Nothing -> pure []
Just x -> pure
. map LText.toStrict
. LText.split (== '\n')
$ LText.decodeUtf8 x
getNumericProjectId :: MonadIO m => Manager -> m Text
getNumericProjectId = getMetadataText "project/numeric-project-id"
getProjectId :: MonadIO m => Manager -> m Text
getProjectId = getMetadataText "project/project-id"
getInstanceAttribute :: MonadIO m => Text -> Manager -> m (Maybe LBS.ByteString)
getInstanceAttribute k =
getMetadataMaybe ("instance/attributes/" <> Text.encodeUtf8 k)
getDescription :: MonadIO m => Manager -> m Text
getDescription = getMetadataText "instance/description"
getHostname :: MonadIO m => Manager -> m Text
getHostname = getMetadataText "instance/hostname"
getInstanceId :: MonadIO m => Manager -> m Text
getInstanceId = getMetadataText "instance/id"
getMachineType :: MonadIO m => Manager -> m Text
getMachineType = getMetadataText "instance/machine-type"
getTags :: MonadIO m => Manager -> m [Text]
getTags m = do
rs <- getMetadata "instance/tags" [] m
case eitherDecode' (Client.responseBody rs) of
Left _ -> pure []
Right xs -> pure xs
getZone :: MonadIO m => Manager -> m Text
getZone = getMetadataText "instance/zone"
getMetadataMaybe :: MonadIO m
=> ByteString
-> Manager
-> m (Maybe LBS.ByteString)
getMetadataMaybe path m = do
rs <- getMetadata path [404] m
if fromEnum (Client.responseStatus rs) == 404
then pure Nothing
else pure $ Just (Client.responseBody rs)
getMetadataText :: MonadIO m
=> ByteString
-> Manager
-> m Text
getMetadataText path m = LText.toStrict . LText.decodeUtf8 . Client.responseBody
<$> getMetadata path [] m
getMetadata :: MonadIO m
=> ByteString
-> [Int]
-> Manager
-> m (Client.Response LBS.ByteString)
getMetadata path statuses m =
liftIO . flip Client.httpLbs m $
metadataRequest
{ Client.path = "/computeMetadata/v1/" <> path
, Client.checkResponse = \rq rs ->
let c = fromEnum (Client.responseStatus rs)
in if 200 <= c && c < 300 && notElem c statuses
then return ()
else do
bs <- Client.brReadSome (Client.responseBody rs) 4096
throwIO . HttpExceptionRequest rq $
StatusCodeException (() <$ rs) (LBS.toStrict bs)
}
metadataRequest :: Client.Request
metadataRequest = Client.defaultRequest
{ Client.host = "metadata.google.internal"
, Client.port = 80
, Client.secure = False
, Client.method = "GET"
, Client.requestHeaders = [(metadataFlavorHeader, metadataFlavorDesired)]
}