@@ -0,0 +1,239 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- |
4+-- Module : Network.Google.Compute.Metadata
5+-- Copyright : (c) 2015 Brendan Hay
6+-- License : Mozilla Public License, v. 2.0.
7+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
8+-- Stability : provisional
9+-- Portability : non-portable (GHC extensions)
10+--
11+-- Google Compute Engine defines a set of default metadata entries that provide
12+-- information about your instance or project. Default metadata is always defined
13+-- and set by the server. You cannot manually edit any of these metadata pairs.
14+module Network.Google.Compute.Metadata
15+ (
16+ -- * Google Compute Instance Check
17+ checkGCEVar
18+ , isGCE
19+
20+ -- * Retrieving Metadata
21+ , getProjectAttribute
22+ , getSSHKeys
23+ , getNumericProjectId
24+ , getProjectId
25+ , getInstanceAttribute
26+ , getDescription
27+ , getHostname
28+ , getInstanceId
29+ , getMachineType
30+ , getTags
31+ , getZone
32+
33+ -- * Raw Metadata Requests
34+ , metadataFlavorHeader
35+ , metadataFlavorDesired
36+ , metadata
37+ , metadataRequest
38+ ) where
39+
40+import Control.Monad.Catch
41+import Control.Monad.IO.Class
42+import Data.Aeson
43+import Data.ByteString (ByteString)
44+import qualified Data.ByteString.Lazy as LBS
45+import Data.Char (toLower)
46+import Data.Default.Class (def)
47+import qualified Data.Text.Encoding as Text
48+import qualified Data.Text.Lazy as LText
49+import qualified Data.Text.Lazy.Encoding as LText
50+import Network.Google.Prelude
51+import Network.HTTP.Conduit (HttpException (..), Manager, httpLbs,
52+ responseBody, responseHeaders,
53+ responseStatus)
54+import qualified Network.HTTP.Conduit as Client
55+import Network.HTTP.Types
56+import System.Environment (lookupEnv)
57+
58+checkGCEVar :: String
59+checkGCEVar = "NO_GCE_CHECK"
60+
61+metadataFlavorHeader :: HeaderName
62+metadataFlavorHeader = "Metadata-Flavor"
63+
64+metadataFlavorDesired :: ByteString
65+metadataFlavorDesired = "Google"
66+
67+metadataRequest :: Client.Request
68+metadataRequest = def
69+ { Client.host = "metadata.google.internal"
70+ , Client.port = 80
71+ , Client.secure = False
72+ , Client.method = "GET"
73+ , Client.requestHeaders = [(metadataFlavorHeader, metadataFlavorDesired)]
74+ }
75+
76+-- | Detect if the underlying host is running on GCE.
77+--
78+-- The environment variable @NO_GCE_CHECK@ can be set to @1@, @true@, @yes@, or @on@
79+-- to skip this check and always return @False@.
80+isGCE :: MonadIO m => Manager -> m Bool
81+isGCE m = liftIO $ do
82+ p <- check <$> lookupEnv checkGCEVar
83+ if p
84+ then (success <$> httpLbs rq m) `catch` failure
85+ else pure False
86+ where
87+ check Nothing = True
88+ check (Just x) = map toLower x `notElem` ["1", "true", "yes", "on"]
89+
90+ success rs =
91+ fromEnum (responseStatus rs) == 200
92+ && (lookup metadataFlavorHeader (responseHeaders rs)
93+ == Just metadataFlavorDesired)
94+
95+ failure :: HttpException -> IO Bool
96+ failure = const (pure False)
97+
98+ rq = metadataRequest
99+ { Client.responseTimeout = Just 1000000
100+ }
101+
102+-- | A directory of custom metadata values that have been set for this project.
103+getProjectAttribute :: MonadIO m => Manager -> Text -> m (Maybe LBS.ByteString)
104+getProjectAttribute m k =
105+ metadataMaybe m ("project/attributes/" <> Text.encodeUtf8 k)
106+
107+-- | SSH keys that can connect to instances in the project. SSH keys for Compute
108+-- Engine use a specialized format where the keys are prepended with a username,
109+-- like so: @user1:ssh-rsa my-public-ssh-key user1@host.com@
110+getSSHKeys :: MonadIO m => Manager -> m [Text]
111+getSSHKeys m = do
112+ mx <- metadataMaybe m "project/attributes/sshKeys"
113+ case mx of
114+ Nothing -> pure []
115+ Just x -> pure
116+ . map LText.toStrict
117+ . LText.split (== '\n')
118+ $ LText.decodeUtf8 x
119+
120+-- | The numeric project ID of the instance, which is not the same as the project
121+-- name visible in the Google Developers Console. This value is different from
122+-- the project-id metadata entry value. The project-id value is required for all
123+-- requests to the Compute Engine service.
124+getNumericProjectId :: MonadIO m => Manager -> m Text
125+getNumericProjectId m = metadataText m "project/numeric-project-id"
126+
127+-- | The project ID.
128+getProjectId :: MonadIO m => Manager -> m Text
129+getProjectId m = metadataText m "project/project-id"
130+
131+-- | A directory of custom metadata values passed to the instance during startup
132+-- or shutdown.
133+getInstanceAttribute :: MonadIO m => Manager -> Text -> m (Maybe LBS.ByteString)
134+getInstanceAttribute m k =
135+ metadataMaybe m ("instance/attributes/" <> Text.encodeUtf8 k)
136+
137+-- | The free-text description of an instance, assigned using the
138+-- @--description@ flag, or set in the API.
139+getDescription :: MonadIO m => Manager -> m Text
140+getDescription m = metadataText m "instance/description"
141+
142+-- | The host name of the instance.
143+getHostname :: MonadIO m => Manager -> m Text
144+getHostname m = metadataText m "instance/hostname"
145+
146+-- | The ID of the instance. This is a unique, numerical ID that is generated by
147+-- Google Compute Engine. This is useful for identifying instances if you do not
148+-- want to use instance names.
149+getInstanceId :: MonadIO m => Manager -> m Text
150+getInstanceId m = metadataText m "instance/id"
151+
152+-- | The fully-qualified machine type name of the instance's host machine.
153+getMachineType :: MonadIO m => Manager -> m Text
154+getMachineType m = metadataText m "instance/machine-type"
155+
156+-- | Any tags associated with the instance.
157+getTags :: MonadIO m => Manager -> m [Text]
158+getTags m = do
159+ rs <- metadata m "instance/tags" []
160+ case eitherDecode' (responseBody rs) of
161+ Left _ -> pure []
162+ Right xs -> pure xs
163+
164+-- | The instance's zone.
165+getZone :: MonadIO m => Manager -> m Text
166+getZone m = metadataText m "instance/zone"
167+
168+-- -- | A directory of disks attached to this instance.
169+-- getDisk ::
170+-- "instance/disks/"
171+
172+-- -- | A directory of service accounts associated with the instance.
173+-- getServiceAccount
174+-- "instance/service-accounts/"
175+
176+-- -- | A directory of network interfaces for the instance.
177+-- getNetworkInterfaces
178+-- "instance/network-interfaces/"
179+
180+-- -- | A directory of any external IPs that are currently pointing to this virtual
181+-- -- machine instance, for the network interface at <index>. Specifically, provides
182+-- -- a list of external IPs served by forwarding rules that direct packets to this
183+-- -- instance.
184+-- getForwardedIPs
185+-- "instance/network-interfaces/<index>/forwarded-ips/"
186+
187+-- -- | A directory with the scheduling options for the instance.
188+-- getScheduling
189+-- "instance/scheduling/"
190+
191+-- -- | The instance's transparent maintenance event behavior setting. This value is
192+-- -- set with the @--on_host_maintenance@ flag or via the API.
193+-- getOnHostMaintenance
194+-- "instance/scheduling/on-host-maintenance"
195+
196+-- -- | The instance's automatic restart setting. This value is set with the
197+-- -- @‑‑automatic_restart@ flag or via the API.
198+-- getAutomaticRestart
199+-- "instance/scheduling/automatic-restart"
200+
201+-- -- | The path that indicates that a transparent maintenance event is affecting this instance.
202+-- -- See Transparent maintenance notice for details.
203+-- getMaintenanceEvent
204+-- "instance/maintenance-event"
205+
206+-- Metadata wait for change
207+-- curl "http://metadata.google.internal/computeMetadata/v1/instance/tags?wait_for_change=true"
208+
209+metadataMaybe :: MonadIO m
210+ => Manager
211+ -> ByteString
212+ -> m (Maybe LBS.ByteString)
213+metadataMaybe m path = do
214+ rs <- metadata m path [404]
215+ if fromEnum (responseStatus rs) == 404
216+ then pure Nothing
217+ else pure $ Just (responseBody rs)
218+
219+metadataText :: MonadIO m
220+ => Manager
221+ -> ByteString
222+ -> m Text
223+metadataText m path = LText.toStrict . LText.decodeUtf8 . responseBody
224+ <$> metadata m path []
225+
226+metadata :: MonadIO m
227+ => Manager
228+ -> ByteString
229+ -> [Int]
230+ -> m (Client.Response LBS.ByteString)
231+metadata m path ss =
232+ liftIO . flip httpLbs m $ metadataRequest
233+ { Client.path = "/computeMetadata/v1/" <> path
234+ , Client.checkStatus = \s hs cj ->
235+ let c = fromEnum s
236+ in if 200 <= c && c < 300 && notElem c ss
237+ then Nothing
238+ else Just . toException $ StatusCodeException s hs cj
239+ }