afab3a3 · gogol · git.iko.soy

gen/src/Gen/AST/Flatten.hs+11−7

@@ -38,10 +38,10 @@ import Prelude hiding (sum)

3838

3939flatten :: Service (Fix Schema) -> AST (Service Global)

4040flatten s = do

41− ps <- Map.traverseWithKey globalParam (s ^. dParameters)

41+ ps <- kvTraverseMaybe globalParam (s ^. dParameters)

4242 rs <- Map.traverseWithKey (resource ps "Resource") (s ^. dResources)

4343 ms <- traverse (method ps "Method") (s ^. dMethods)

44− _ <- Map.traverseWithKey globalSchema (s ^. dSchemas)

44+ _ <- Map.traverseWithKey globalSchema (s ^. dSchemas)

4545

4646 -- The horror.

4747 ss <- use schemas

@@ -110,12 +110,16 @@ schema g ml (Fix f) = go (maybe g (reference g) ml) f >>= uncurry insert

110110 format ("Unable to generate name for reserved schema: " % gid % ", " % shown % ", " % gid)

111111 g ml p

112112

113−globalParam :: Local -> Param (Fix Schema) -> AST (Param Global)

113+globalParam :: Local -> Param (Fix Schema) -> AST (Maybe (Param Global))

114114globalParam l p = case l of

115− "alt" -> overrideParam l (Alt alt) p

116− "key" -> overrideParam l Key p

117− "oauth_token" -> overrideParam l OAuthToken (p & pLocation .~ Header)

118− _ -> localParam "" l p

115+ "key" -> pure Nothing

116+ "oauth_token" -> pure Nothing

117+ "prettyPrint" -> pure Nothing

118+ "quotaUser" -> pure Nothing

119+ "fields" -> pure Nothing

120+ "userIp" -> pure Nothing

121+ "alt" -> Just <$> overrideParam l (Alt alt) p

122+ _ -> Just <$> localParam "" l p

119123 where

120124 alt = alternate $ fromMaybe "JSON" (p ^. iDefault)

121125

gen/src/Gen/AST/Render.hs+17−4

@@ -33,6 +33,7 @@ import Data.Semigroup ((<>))

3333import qualified Data.Text as Text

3434import qualified Data.Text.Lazy as LText

3535import qualified Data.Text.Lazy.Builder as Build

36+import Data.Text.Manipulate

3637import Debug.Trace

3738import Gen.AST.Solve (getSolved)

3839import Gen.Formatting

@@ -106,13 +107,15 @@ renderAPI s = do

106107

107108 d <- pp Print $ apiAlias alias (map _actAliasName (rs <> ms))

108109

109− API alias d rs ms <$> serviceURL

110+ API alias d rs ms

111+ <$> svc

112+ <*> traverse scp (maybe mempty (Map.toList . scopes) (s ^. dAuth))

110113 where

111114 alias = aname (_sCanonicalName s)

112115

113116 url = name (Text.unpack (urlName s))

114117

115− serviceURL = Fun' url (Just (rawHelpText h))

118+ svc = Fun' url (Just (rawHelpText h))

116119 <$> pp None (urlSig url)

117120 <*> pp Print (urlDecl s url)

118121 where

@@ -120,16 +123,26 @@ renderAPI s = do

120123 "@ of the " % stext % ". This contains the host and root path used as a starting point for constructing service requests.")

121124 (s ^. dVersion) (s ^. dTitle)

122125

126+ scp (k, h) = Fun' n (Just h)

127+ <$> pp None (scopeSig n)

128+ <*> pp None (scopeDecl n k)

129+ where

130+ n = name

131+ . Text.unpack

132+ . (<> "Scope")

133+ . toCamel

134+ . last

135+ $ Text.split (== '/') k

136+

123137renderMethod :: Service a -> NS -> Suffix -> Method Solved -> AST Action

124138renderMethod s root suf m@Method {..} = do

125139 x@Solved {..} <- getSolved typ

126140 Just d <- renderSchema x

127141

128− a <- pp Print $ authDecl _unique _prefix (props _schema)

129142 i <- pp Print $ requestDecl _unique _prefix alias url (props _schema) m

130143 dl <- pp Print $ downloadDecl _unique _prefix alias url (props _schema) m

131144

132− let is = a : i : [dl | _mSupportsMediaDownload]

145+ let is = i : [dl | _mSupportsMediaDownload]

133146

134147 Action _mId _unique (root <> mkNS ns) _mDescription alias

135148 <$> pp Print (verbAlias alias m)

gen/src/Gen/AST/Solve.hs−2

@@ -135,8 +135,6 @@ getDerive g = loc "getDerive" g $ memo derived g go

135135 Date -> DRead : base

136136 Body -> []

137137 Alt _ -> DRead : base

138− Key -> DRead : base

139− OAuthToken -> DRead : base

140138 JSONValue -> DRead : base

141139 -- FIXME: Add numeric cases

142140 _ -> [DRead, DNum, DIntegral, DReal] <> enum

gen/src/Gen/Syntax.hs+16−27

@@ -34,16 +34,25 @@ import Language.Haskell.Exts.SrcLoc

3434import Language.Haskell.Exts.Syntax hiding (Alt, Int, Lit)

3535

3636urlSig :: Name -> Decl

37−urlSig n = TypeSig noLoc [n] (TyCon "RequestBuilder")

37+urlSig n = TypeSig noLoc [n] (TyCon "Service")

3838

3939urlDecl :: Service a -> Name -> Decl

4040urlDecl s n = sfun noLoc n [] (UnGuardedRhs rhs) noBinds

4141 where

42− rhs = appFun (var "defaultRequest")

43− [ str (s ^. dRootUrl)

42+ rhs = appFun (var "defaultService")

43+ [ app (var "ServiceId") (str (s ^. dId))

44+ , str . stripSuffix "/" $ stripPrefix "https://" (s ^. dRootUrl)

4445 , str (s ^. dServicePath)

4546 ]

4647

48+scopeSig :: Name -> Decl

49+scopeSig n = TypeSig noLoc [n] (TyCon "OAuthScope")

50+

51+scopeDecl :: Name -> Text -> Decl

52+scopeDecl n s = sfun noLoc n [] (UnGuardedRhs rhs) noBinds

53+ where

54+ rhs = app (var "OAuthScope") (str s)

55+

4756 -- type API = :<|> ...

4857apiAlias :: Name -> [Name] -> Decl

4958apiAlias n ls = TypeDecl noLoc n [] alias

@@ -97,8 +106,6 @@ verbAlias n m

97106 let t = terminalType (_type (_pParam x))

98107 n = sing (local k)

99108 in case _pLocation x of

100− Header | local k == "oauth_token"

101− -> Just $ TyApp (TyApp (TyCon "Header") (sing "Authorization")) t

102109 Query | x ^. iRepeated

103110 -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t

104111 Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t

@@ -188,21 +195,18 @@ googleRequestDecl g n assoc alt p api url fields m pat prec =

188195 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n]

189196 [ assoc

190197 , request

191− , requestWith

192198 ]

193199 where

194− request = funD "request" $ app (var "requestWith") (var url)

195−

196− requestWith = InsDecl (FunBind [match])

200+ request = InsDecl (FunBind [match])

197201 where

198− match = Match noLoc (name "requestWith") pats Nothing rhs decls

202+ match = Match noLoc (name "requestClient") [prec] Nothing rhs decls

199203

200204 decls = BDecls

201205 [ patBind noLoc pat $

202206 appFun (var "clientBuild") $

203207 [ ExpTypeSig noLoc (var "Proxy") $

204208 TyApp (TyCon "Proxy") (TyCon (UnQual api))

205− , var "rq"

209+ , var "mempty"

206210 ]

207211 ]

208212

@@ -210,6 +214,7 @@ googleRequestDecl g n assoc alt p api url fields m pat prec =

210214 ++ maybeToList (app (var "Just") <$> alt)

211215 ++ maybeToList (go <$> rq)

212216 ++ maybeToList (go <$> pay)

217+ ++ [var url]

213218 where

214219 go l = case Map.lookup l ps of

215220 Just p | _pLocation p == Query

@@ -240,18 +245,6 @@ googleRequestDecl g n assoc alt p api url fields m pat prec =

240245 . nub

241246 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m

242247

243− pats = [pvar "rq", prec]

244−

245−authDecl :: Global -> Prefix -> [Local] -> Decl

246−authDecl g p fs = InstDecl noLoc Nothing [] [] (unqual "GoogleAuth") [tycon g]

247− [ method "_AuthKey" "key"

248− , method "_AuthToken" "oauth_token"

249− ]

250− where

251− method l f

252− | f `elem` fs = funD l (infixApp (var (lname p f)) "." (var "_Just"))

253− | otherwise = funD l (app (var "const") (var "pure"))

254−

255248jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]

256249jsonDecls g p (Map.toList -> rs) = [from, to]

257250 where

@@ -458,8 +451,6 @@ externalLit = \case

458451 Int64 -> TyCon "Int64"

459452

460453 Alt t -> TyCon (unqual (Text.unpack t))

461− Key -> TyCon "AuthKey"

462− OAuthToken -> TyCon "OAuthToken"

463454 Body -> TyCon "Stream"

464455 JSONValue -> TyCon "JSONValue"

465456

@@ -480,8 +471,6 @@ internalLit = \case

480471 Int64 -> TyCon "Int64"

481472

482473 Alt t -> TyCon (unqual (Text.unpack t))

483− Key -> TyCon "AuthKey"

484− OAuthToken -> TyCon "OAuthToken"

485474 Body -> TyCon "Stream"

486475 JSONValue -> TyCon "JSONValue"

487476

gen/src/Gen/Types.hs+1

@@ -256,6 +256,7 @@ instance ToJSON Library where

256256 , "documentationLink" .= (l ^. dDocumentationLink)

257257 , "labels" .= (l ^. dLabels)

258258 , "features" .= (l ^. dFeatures)

259+ , "scopes" .= (l ^. dAuth)

259260

260261 -- API

261262 , "api" .= (l ^. lAPI)

gen/src/Gen/Types/Data.hs+2

@@ -121,6 +121,7 @@ data API = API

121121 , _apiResources :: [Action]

122122 , _apiMethods :: [Action]

123123 , _apiURL :: Fun

124+ , _apuScopes :: [Fun]

124125 }

125126

126127instance ToJSON API where

@@ -131,4 +132,5 @@ instance ToJSON API where

131132 , "resources" .= sortOn _actId _apiResources

132133 , "methods" .= sortOn _actId _apiMethods

133134 , "url" .= _apiURL

135+ , "scopes" .= _apuScopes

134136 ]

gen/src/Gen/Types/Id.hs+2−4

@@ -190,7 +190,7 @@ extractPath x = either (error . err) id $ A.parseOnly path x

190190 where

191191 err e = "Error parsing \"" <> Text.unpack x <> "\", " <> e

192192

193− path = A.many1 (seg <|> repeat <|> var) <* A.endOfInput

193+ path = A.many1 (seg <|> repeat <|> var') <* A.endOfInput

194194

195195 seg = fmap Left $

196196 optional (A.char '/') *> A.takeWhile1 (A.notInClass "/{+*}")

@@ -200,7 +200,7 @@ extractPath x = either (error . err) id $ A.parseOnly path x

200200 (,Nothing) <$> fmap Local (A.takeWhile1 (/= '*'))

201201 <* A.string "*}"

202202

203− var = fmap Right $ do

203+ var' = fmap Right $ do

204204 void $ optional (A.char '/') *> A.char '{' *> optional (A.char '+')

205205 (,) <$> fmap Local (A.takeWhile1 (A.notInClass "/{+*}:"))

206206 <* A.char '}'

@@ -222,8 +222,6 @@ orderParams f xs ys = orderBy f zs (del zs [] ++ global)

222222 , "prettyPrint"

223223 , "userIp"

224224 , "fields"

225− , "key"

226− , "oauth_token"

227225 , "alt"

228226 ]

229227

gen/src/Gen/Types/Schema.hs+2−5

@@ -54,7 +54,6 @@ newtype Fix f = Fix (f (Fix f))

5454data Location

5555 = Query

5656 | Path

57− | Header

5857 deriving (Eq, Show)

5958

6059deriveJSON options ''Location

@@ -203,8 +202,6 @@ data Lit

203202 | Body

204203 | JSONValue

205204 | Alt Text

206− | Key

207− | OAuthToken

208205 deriving (Eq, Show)

209206

210207instance FromJSON Lit where

@@ -331,7 +328,7 @@ instance FromJSON a => FromJSON (Resource a) where

331328 <*> (o .:? "methods" .!= mempty <&> keyless)

332329

333330newtype OAuth2 = OAuth2 { scopes :: Map Text Help }

334− deriving (Eq, Show)

331+ deriving (Eq, Show, ToJSON)

335332

336333instance FromJSON OAuth2 where

337334 parseJSON = withObject "oauth2" $ \x -> do

@@ -436,4 +433,4 @@ instance HasDescription (Service a) a where

436433 description = sDescription

437434

438435urlName :: Service a -> Text

439−urlName = (<> "Request") . lowerHead . _sCanonicalName

436+urlName = (<> "Service") . toCamel . _sCanonicalName

gen/template/toc.ede+4−1

@@ -12,8 +12,11 @@

1212-- /See:/ <{{ documentationLink }} {{ title }} Reference>

1313module {{ moduleName }}

1414 (

15+ -- * Service Configuration

16+ {{ api.url.name }}

17+

1518 -- * API Declaration

16− {{ api.aliasName }}

19+ , {{ api.aliasName }}

1720 {% for action in api.methods %}

1821 {% if action.first %}

1922

gen/template/types.ede+16−1

@@ -9,8 +9,15 @@

99--

1010module {{ moduleName }}

1111 (

12− -- * Service Request

12+ -- * Service Configuration

1313 {{ api.url.name }}

14+ {% for scope in api.scopes %}

15+ {% if scope.first %}

16+

17+ -- * OAuth Scopes

18+ {% endif %}

19+ , {{ scope.value.name }}

20+ {% endfor %}

1421 {% for schema in schemas %}

1522 {% case schema.value.type %}

1623 {% when "prod" %}

@@ -38,3 +45,11 @@ import {{ import.value }}

3845{% endif %}

3946{{ api.url.sig }}

4047{{ api.url.decl }}

48+{% for scope in api.scopes %}

49+

50+{% if scope.value.help %}

51+{{ scope.value.help }}

52+{% endif %}

53+{{ scope.value.sig }}

54+{{ scope.value.decl }}

55+{% endfor %}