module Google.Cloud.Compute.Metadata where
import Control.Applicative
import Control.Monad
import Control.Monad.Except
import Data.Char
import Data.ByteString (ByteString, split)
import Data.ByteString.Char8 (unpack)
import Data.Text (Text)
import Data.Text.Encoding
import Data.Monoid
import Data.Time
import Data.Aeson
import Data.Scientific
import qualified Data.HashMap.Strict as HMS
import Google.Cloud.Internal.Types
import Google.Cloud.Internal.HTTP
import Prelude
metadataServer :: String
metadataServer = "http://metadata.google.internal"
projectMetadataPath :: String
projectMetadataPath = "/computeMetadata/v1/project"
instanceMetadataPath :: String
instanceMetadataPath = "/computeMetadata/v1/instance"
readKey :: String -> Cloud ByteString
readKey key = get (metadataServer ++ key) [("Metadata-Flavor","Google")]
readJSON :: (FromJSON a) => String -> Cloud a
readJSON key = getJSON (metadataServer ++ key) [("Metadata-Flavor","Google")]
newtype ProjectId = ProjectId { unProjectId :: Text }
projectId :: Cloud ProjectId
projectId = ProjectId . decodeUtf8
<$> readKey (projectMetadataPath ++ "/project-id")
newtype NumericProjectId = NumericProjectId { unNumericProjectId :: Integer }
numericProjectId :: Cloud NumericProjectId
numericProjectId = readKey (projectMetadataPath ++ "/numeric-project-id") >>=
(cloudIO . return . NumericProjectId . read . unpack)
type Attribute = (ByteString, ByteString)
projectAttributes :: Cloud [Attribute]
projectAttributes = do
let baseKey = projectMetadataPath ++ "/attributes/"
keys <- split (fromIntegral $ ord '\n') <$> readKey baseKey
forM keys $ \key -> ((,) key) <$> readKey (baseKey <> unpack key)
newtype InstanceId = InstanceId { unInstanceId :: Integer }
instanceId :: Cloud InstanceId
instanceId = readKey (instanceMetadataPath ++ "/id") >>=
(cloudIO . return . InstanceId . read . unpack)
newtype MachineType = MachineType { unMachineType :: Text }
machineType :: Cloud MachineType
machineType = MachineType . decodeUtf8
<$> readKey (instanceMetadataPath ++ "/machine-type")
internalHostname :: Cloud String
internalHostname = unpack <$> readKey (instanceMetadataPath ++ "/hostname")
newtype Zone = Zone { unZone :: Text }
zone :: Cloud Zone
zone = Zone . decodeUtf8 <$> readKey (instanceMetadataPath ++ "/zone")
serviceAccountToken :: String -> Cloud Token
serviceAccountToken acc = do
res <- readJSON (instanceMetadataPath ++ "/service-account/" ++ acc ++ "/token")
case res of
(Object o) -> case (HMS.lookup "access_token" o, HMS.lookup "expires_in" o) of
(Just (String value), Just (Number expiresIn)) -> do
case toBoundedInteger expiresIn :: Maybe Int of
Nothing -> throwError $ UnknownError "fetchToken: Bad expiration time"
Just i -> do
now <- cloudIO $ getCurrentTime
return $ Token (addUTCTime (fromIntegral i) now) value
_ -> throwError $ UnknownError "fetchToken: Could not decode response"
_ -> throwError $ UnknownError "fetchToken: Bad resposnse"