@@ -0,0 +1,336 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE TemplateHaskell #-}
4+
5+module Gen.Schema where
6+
7+import Control.Applicative
8+import Control.Lens hiding ((.=))
9+import Data.Aeson hiding (Array, Bool, Object,
10+ String)
11+import qualified Data.Aeson as A
12+import Data.Aeson.TH
13+import Data.Char
14+import Data.Function (on)
15+import qualified Data.HashMap.Strict as Map
16+import qualified Data.HashSet as Set
17+import Data.List (groupBy, sort, sortOn)
18+import Data.List.NonEmpty (NonEmpty (..))
19+import qualified Data.List.NonEmpty as NE
20+import Data.Maybe
21+import Data.Ord
22+import Data.Semigroup ((<>))
23+import Data.Text (Text)
24+import qualified Data.Text as Text
25+import qualified Data.Text.Lazy as LText
26+import qualified Data.Text.Lazy.Builder as Build
27+import Data.Text.Manipulate
28+import qualified Data.Text.Read as Read
29+import qualified Filesystem.Path.CurrentOS as Path
30+import Formatting
31+import Gen.Orphans ()
32+import Gen.Text
33+import Gen.Types.Help
34+import Gen.Types.Id
35+import Gen.Types.Map
36+import Gen.Types.NS
37+import GHC.Generics
38+import GHC.TypeLits
39+import Language.Haskell.Exts (Name)
40+import Language.Haskell.Exts.Pretty (Pretty, prettyPrint)
41+import Prelude hiding (Enum)
42+import Text.EDE (Template)
43+
44+newtype Fix f = Fix (f (Fix f))
45+
46+type Set = Set.HashSet
47+type Error = LText.Text
48+type Rendered = LText.Text
49+type Path = Path.FilePath
50+
51+data Location
52+ = Query
53+ | Path
54+ deriving (Eq, Show)
55+
56+deriveJSON options ''Location
57+
58+newtype Ann = Ann { annRequired :: [Text] }
59+ deriving (Eq, Show, Monoid)
60+
61+deriveJSON options ''Ann
62+
63+data Info = Info
64+ { _iId :: Maybe Text
65+ , _iDescription :: Maybe Help
66+ , _iDefault :: Maybe Text
67+ , _iRequired :: Bool
68+ , _iPattern :: Maybe Text
69+ , _iMinimum :: Maybe Text
70+ , _iMaximum :: Maybe Text
71+ , _iRepeated :: Bool
72+ , _iAnnotations :: Ann
73+ } deriving (Eq, Show)
74+
75+makeClassy ''Info
76+
77+instance FromJSON Info where
78+ parseJSON = withObject "info" $ \o -> Info
79+ <$> o .: "id"
80+ <*> o .:? "description"
81+ <*> o .:? "default"
82+ <*> o .:? "required" .!= False
83+ <*> o .:? "pattern"
84+ <*> o .:? "minimum"
85+ <*> o .:? "maximum"
86+ <*> o .:? "repeated" .!= False
87+ <*> o .:? "annotations" .!= mempty
88+
89+data Schema
90+ = SRef Info Ref
91+ | SLit Info Literal
92+ | SEnum Info Enum
93+ | SArr Info Array
94+ | SObj Info Object
95+ deriving (Eq, Show)
96+
97+instance FromJSON Schema where
98+ parseJSON o = do
99+ i <- parseJSON o
100+ SRef i <$> parseJSON o
101+ <|> SLit i <$> parseJSON o
102+ <|> SEnum i <$> parseJSON o
103+ <|> SArr i <$> parseJSON o
104+ <|> SObj i <$> parseJSON o
105+
106+instance HasInfo Schema where
107+ info = lens f (flip g)
108+ where
109+ f = \case
110+ SRef i _ -> i
111+ SLit i _ -> i
112+ SEnum i _ -> i
113+ SArr i _ -> i
114+ SObj i _ -> i
115+
116+ g i = \case
117+ SRef _ x -> SRef i x
118+ SLit _ x -> SLit i x
119+ SEnum _ x -> SEnum i x
120+ SArr _ x -> SArr i x
121+ SObj _ x -> SObj i x
122+
123+newtype Ref = Ref { ref :: Text }
124+ deriving (Eq, Show)
125+
126+instance FromJSON Ref where
127+ parseJSON = withObject "ref" (fmap Ref . (.: "$ref"))
128+
129+data Literal
130+ = Text
131+ | Bool
132+ | Float
133+ | Double
134+ | Byte
135+ | UInt32
136+ | UInt64
137+ | Int32
138+ | Int64
139+ | Date
140+ | Time
141+ deriving (Eq, Show)
142+
143+instance FromJSON Literal where
144+ parseJSON = withObject "literal" $ \o -> do
145+ t <- o .: "format" <|> o .: "type"
146+ case t of
147+ -- Types
148+ "string" -> pure Text
149+ "boolean" -> pure Bool
150+
151+ -- Formats
152+ "float" -> pure Float
153+ "double" -> pure Double
154+ "byte" -> pure Byte
155+ "uint32" -> pure UInt32
156+ "uint64" -> pure UInt64
157+ "int32" -> pure Int32
158+ "int64" -> pure Int64
159+ "date" -> pure Date
160+ "date-time" -> pure Time
161+
162+ _ -> fail $
163+ "Unable to parse Literal from: " ++ Text.unpack t
164+
165+newtype Enum = Enum { _eValues :: [(Text, Help)] }
166+ deriving (Eq, Show)
167+
168+instance FromJSON Enum where
169+ parseJSON = withObject "enum" $ \o -> do
170+ vs <- o .: "enum"
171+ ds <- o .: "enumDescriptions"
172+ pure $! Enum (zip vs (ds ++ repeat mempty))
173+
174+newtype Array = Array { _aItem :: Schema }
175+ deriving (Eq, Show)
176+
177+instance FromJSON Array where
178+ parseJSON = withObject "array" (fmap Array . (.: "item"))
179+
180+data Object = Object
181+ { _oProperties :: Map Text Schema
182+ , _oAdditionalProperties :: Maybe Schema
183+ } deriving (Eq, Show)
184+
185+deriveFromJSON options ''Object
186+
187+data Param = Param
188+ { _pLocation :: Location
189+ , _pSchema :: Schema
190+ } deriving (Eq, Show)
191+
192+makeLenses ''Param
193+
194+instance FromJSON Param where
195+ parseJSON = withObject "param" $ \o -> Param
196+ <$> o .: "location"
197+ <*> parseJSON (A.Object o)
198+
199+instance HasInfo Param where
200+ info = pSchema . info
201+
202+data MediaUpload = MediaUpload
203+ { _muAccept :: [Text]
204+ , _muMaxSize :: Text
205+ , _muResumablePath :: Text
206+ , _muSimplePath :: Text
207+ } deriving (Eq, Show)
208+
209+instance FromJSON MediaUpload where
210+ parseJSON = withObject "mediaUpload" $ \o -> MediaUpload
211+ <$> o .: "accept"
212+ <*> o .: "maxSize"
213+ <*> (o .: "protocols" >>= (.: "resumable") >>= (.: "path"))
214+ <*> (o .: "protocols" >>= (.: "simple") >>= (.: "path"))
215+
216+data Method = Method
217+ { _mId :: Text
218+ , _mPath :: Text
219+ , _mHttpMethod :: Text
220+ , _mDescription :: Help
221+ , _mParameters :: Map Text Param
222+ , _mParameterOrder :: [Text]
223+ , _mRequest :: Maybe Ref
224+ , _mResponse :: Maybe Ref
225+ , _mScopes :: [Text]
226+ , _mSupportsMediaUpload :: Bool
227+ , _mSupportsMediaDownload :: Bool
228+ , _mMediaUpload :: Maybe MediaUpload
229+ , _mSupportsSubscription :: Bool
230+ } deriving (Eq, Show)
231+
232+instance FromJSON Method where
233+ parseJSON = withObject "method" $ \o -> Method
234+ <$> o .: "id"
235+ <*> o .: "path"
236+ <*> o .: "httpMethod"
237+ <*> o .: "description"
238+ <*> o .:? "parameters" .!= mempty
239+ <*> o .:? "parameterOrder" .!= mempty
240+ <*> o .:? "request"
241+ <*> o .:? "response"
242+ <*> o .:? "scopes" .!= mempty
243+ <*> o .:? "supportsMediaUpload" .!= False
244+ <*> o .:? "supportsMediaDownload" .!= False
245+ <*> o .:? "mediaUpload"
246+ <*> o .:? "supportsSubscription" .!= False
247+
248+data Resource = Resource
249+ { _rMethods :: Map Text Method
250+ , _rResources :: Map Text Resource
251+ } deriving (Eq, Show)
252+
253+instance FromJSON Resource where
254+ parseJSON = withObject "resource" $ \o -> Resource
255+ <$> o .:? "methods" .!= mempty
256+ <*> o .:? "resources" .!= mempty
257+
258+newtype OAuth2 = OAuth2 { scopes :: Map Text Text }
259+ deriving (Eq, Show)
260+
261+instance FromJSON OAuth2 where
262+ parseJSON = withObject "oauth2" $ \o ->
263+ o .: "oauth2" >>=
264+ withObject "scopes" (.: "scopes")
265+
266+data Description = Description
267+ { _dKind :: Text
268+ , _dDiscoveryVersion :: Text
269+ , _dId :: Text
270+ , _dName :: Text
271+ , _dVersion :: Text
272+ , _dRevision :: Text
273+ , _dTitle :: Text
274+ , _dDescription :: Help
275+ , _dIcons :: Map Text Text
276+ , _dDocumentationLink :: Text
277+ , _dLabels :: Text
278+ , _dProtocol :: Text
279+ , _dBaseUrl :: Text
280+ , _dRootUrl :: Text
281+ , _dServicePath :: Text
282+ , _dBatchPath :: Text
283+ , _dParameters :: Map Text Param
284+ , _dAuth :: OAuth2
285+ , _dFeatures :: [Text]
286+ , _dSchemas :: Map Text Schema
287+ , _dMethods :: Map Text Method
288+ , _dResources :: Map Text Resource
289+ } deriving (Eq, Show)
290+
291+makeClassy ''Description
292+
293+instance FromJSON Description where
294+ parseJSON = withObject "description" $ \o -> Description
295+ <$> o .: "kind"
296+ <*> o .: "discoveryVersion"
297+ <*> o .: "id"
298+ <*> o .: "name"
299+ <*> o .: "version"
300+ <*> o .: "revision"
301+ <*> o .: "title"
302+ <*> o .: "description"
303+ <*> o .: "icons"
304+ <*> o .: "documentationLink"
305+ <*> o .: "labels"
306+ <*> o .: "protocol"
307+ <*> o .: "baseUrl"
308+ <*> o .: "rootUrl"
309+ <*> o .: "servicePath"
310+ <*> o .: "batchPath"
311+ <*> o .:? "parameters" .!= mempty
312+ <*> o .: "auth"
313+ <*> o .:? "features" .!= mempty
314+ <*> o .:? "schemas" .!= mempty
315+ <*> o .:? "methods" .!= mempty
316+ <*> o .:? "resources" .!= mempty
317+
318+data Service = Service
319+ { _sLibrary :: Text
320+ , _sCanonicalName :: Text
321+ , _sOwnerName :: Text
322+ , _sOwnerDomain :: Text
323+ , _sPackagePath :: Maybe Text
324+ , _sDescription :: Description
325+ } deriving (Eq, Show)
326+
327+makeLenses ''Service
328+
329+instance FromJSON Service where
330+ parseJSON = withObject "service" $ \o -> Service
331+ <$> o .: "library"
332+ <*> o .: "canonicalName"
333+ <*> o .: "ownerName"
334+ <*> o .: "ownerDomain"
335+ <*> o .: "packagePath"
336+ <*> parseJSON (A.Object o)