Last active
August 19, 2019 19:38
-
-
Save 1602/668d5ee8095fc866992ec8015527a058 to your computer and use it in GitHub Desktop.
json-schema.org parser
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{ | |
"version": "1.0.0", | |
"summary": "helpful summary of your project, less than 80 characters", | |
"repository": "https://github.com/user/project.git", | |
"license": "BSD3", | |
"source-directories": [ | |
"./src" | |
], | |
"exposed-modules": [], | |
"dependencies": { | |
"elm-community/json-extra": "1.1.0 <= v < 2.0.0", | |
"elm-lang/core": "4.0.0 <= v < 5.0.0", | |
"elm-lang/html": "1.0.0 <= v < 2.0.0", | |
"evancz/elm-http": "3.0.1 <= v < 4.0.0" | |
}, | |
"elm-version": "0.17.0 <= v < 0.18.0" | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
port module Main exposing (..) | |
import Json.Decode as Decode exposing (Decoder, maybe, string, bool, succeed, (:=)) | |
import Json.Decode.Extra as DecodeExtra exposing ((|:), withDefault, lazy) | |
import Json.Encode as Encode exposing (Value) | |
import Http | |
import Html exposing (div, span, button, text, form, input, ul, li) | |
import Html.App exposing (program) | |
import Html.Events exposing (onClick, onSubmit, onInput) | |
import Html.Attributes as Attrs exposing (style) | |
import Task | |
import Dict | |
import Set | |
import String | |
main : Program Never | |
main = | |
program | |
{ init = init | |
, view = view | |
, update = update | |
, subscriptions = subscriptions | |
} | |
-- MODEL | |
type alias Id = | |
String | |
type alias Model = | |
{ services : Maybe (List ServiceDescriptor) | |
, error : String | |
, credentials : String | |
, schema : Maybe Schema | |
, input : InputData | |
, serviceId : Id | |
, job : Maybe Job | |
} | |
type alias InputData = | |
Dict.Dict String Value | |
type alias ServiceDescriptor = | |
{ id : Id | |
, name : String | |
, type' : String | |
} | |
type alias Schema = | |
{ properties : Properties | |
, required : Set.Set String | |
, type' : String | |
, format : Maybe String | |
, ref : Maybe String | |
, definitions : Properties | |
, enum : Maybe (List String) | |
} | |
type Properties | |
= Properties (List ( String, Schema )) | |
type alias Job = | |
{ id : Id | |
, state : String | |
} | |
fetchServices : String -> Cmd Msg | |
fetchServices credentials = | |
Task.perform FetchError | |
FetchServicesSuccess | |
(Http.fromJson | |
(Decode.at [ "data" ] (Decode.list decodeService)) | |
(Http.send | |
Http.defaultSettings | |
{ verb = "GET" | |
, headers = [ ( "Authorization", "Basic " ++ credentials ) ] | |
, url = "http://localhost:3000/services" | |
, body = Http.empty | |
} | |
) | |
) | |
fetchSchema : String -> Id -> Cmd Msg | |
fetchSchema credentials id = | |
Task.perform FetchError | |
FetchSchemaSuccess | |
(Http.fromJson | |
(Decode.at [ "schema" ] decodeSchema) | |
(Http.send | |
Http.defaultSettings | |
{ verb = "GET" | |
, headers = [ ( "Authorization", "Basic " ++ credentials ) ] | |
, url = "http://localhost:3000/services/" ++ id | |
, body = Http.empty | |
} | |
) | |
) | |
submitJob : String -> Id -> InputData -> Cmd Msg | |
submitJob credentials serviceId inputData = | |
Task.perform FetchError | |
FetchJobSuccess | |
(Http.fromJson | |
decodeJob | |
(Http.send | |
Http.defaultSettings | |
{ verb = "POST" | |
, headers = [ ( "Authorization", "Basic " ++ credentials ) ] | |
, url = "http://localhost:3000/jobs" | |
, body = | |
Http.string | |
(Encode.encode 0 | |
(Encode.object | |
[ ( "service_id", Encode.string serviceId ) | |
, ( "input", Encode.object (Dict.toList inputData) ) | |
] | |
) | |
) | |
} | |
) | |
) | |
decodeJob : Decoder Job | |
decodeJob = | |
succeed Job | |
|: ("id" := string) | |
|: ("state" := string) | |
decodeService : Decoder ServiceDescriptor | |
decodeService = | |
succeed ServiceDescriptor | |
|: ("id" := string) | |
|: ("name" := string) | |
|: ("type" := string) | |
decodeSchema : Decoder Schema | |
decodeSchema = | |
succeed Schema | |
|: (withDefault (Properties []) ("properties" := decodeProperties)) | |
|: (withDefault Set.empty ("required" := DecodeExtra.set string)) | |
|: (withDefault "object" ("type" := string)) | |
|: (maybe ("format" := string)) | |
|: (maybe ("$ref" := string)) | |
|: (withDefault (Properties []) ("definitions" := decodeProperties)) | |
|: (maybe ("enum" := (Decode.list string))) | |
-- Decode.object4 (\p r t f -> Schema { properties = p, required = r, type' = t, format = f }) | |
-- ("properties" := decodeProperties) | |
-- (withDefault Set.empty ("required" := DecodeExtra.set string)) | |
-- ("type" := string) | |
-- (maybe ("format" := string)) | |
decodeProperties : Decoder Properties | |
decodeProperties = | |
succeed Properties | |
|: Decode.keyValuePairs (DecodeExtra.lazy (\_ -> decodeSchema)) | |
init : ( Model, Cmd msg ) | |
init = | |
Model | |
-- list services | |
Nothing | |
-- error | |
"" | |
-- credentials | |
"MjRmMmY0ZDg1NTM3MTk1MDQ2ZjM0YmE5NWRiYzQ0ODU1MTU4ZDE4MmFkM2Y5NmExOg==" | |
-- schema | |
Nothing | |
-- input | |
Dict.empty | |
-- serviceId | |
"" | |
-- job | |
Nothing | |
! [] | |
-- UPDATE | |
type Msg | |
= NoOp | |
| SetCredentials String | |
| FetchServices | |
| FetchError Http.Error | |
| FetchServicesSuccess (List ServiceDescriptor) | |
| FetchSchema Id | |
| FetchSchemaSuccess Schema | |
| UpdateProperty (List String) String | |
| SubmitJob | |
| FetchJobSuccess Job | |
update : Msg -> Model -> ( Model, Cmd Msg ) | |
update msg model = | |
-- case Debug.log "update" msg of | |
case msg of | |
NoOp -> | |
model ! [] | |
SetCredentials c -> | |
{ model | credentials = c } ! [] | |
FetchServices -> | |
model ! [ fetchServices model.credentials ] | |
FetchError err -> | |
{ model | error = toString err } ! [] | |
FetchServicesSuccess svcs -> | |
{ model | services = Just svcs } ! [] | |
FetchSchema id -> | |
{ model | serviceId = id } ! [ fetchSchema model.credentials id ] | |
FetchSchemaSuccess schema -> | |
{ model | schema = Just schema } ! [] | |
UpdateProperty path value -> | |
let | |
upd = | |
update value path model.input | |
encodeDict dict = | |
Encode.object (Dict.toList dict) | |
valueDecoder = | |
Decode.oneOf | |
[ Decode.map (\s -> Encode.string s) string | |
, Decode.map (\d -> encodeDict d) | |
(Decode.dict (DecodeExtra.lazy (\_ -> valueDecoder))) | |
] | |
decodeDict val = | |
Decode.decodeValue (Decode.dict valueDecoder) val | |
|> Result.withDefault Dict.empty | |
update finalValue subPath dataNode = | |
case subPath of | |
name :: [] -> | |
(Dict.insert name | |
(Encode.string finalValue) | |
dataNode | |
) | |
head :: tail -> | |
(Dict.get head dataNode | |
|> Maybe.withDefault (encodeDict Dict.empty) | |
|> decodeDict | |
|> update finalValue tail | |
|> encodeDict | |
|> Dict.insert head | |
) | |
dataNode | |
|> Debug.log (head ++ ":tail") | |
_ -> | |
dataNode | |
in | |
{ model | input = upd } ! [] | |
SubmitJob -> | |
model ! [ submitJob model.credentials model.serviceId model.input ] | |
FetchJobSuccess job -> | |
{ model | job = Just job } ! [] | |
-- port alert : String -> Cmd msg | |
-- port log : (String -> msg) -> Sub msg | |
-- SUBSCRIPTIONS | |
subscriptions : Model -> Sub Msg | |
subscriptions model = | |
Sub.batch | |
[ Sub.none | |
] | |
-- VIEW | |
boxStyle : List ( String, String ) | |
boxStyle = | |
[ ( "border", "1px solid #ddd" ) | |
, ( "border-radius", "2px" ) | |
, ( "padding", "10px" ) | |
, ( "margin", "10px" ) | |
] | |
entityRowStyle : List ( String, String ) | |
entityRowStyle = | |
[ ( "padding", "5px" ) | |
, ( "background", "#eee" ) | |
, ( "margin-top", "5px" ) | |
, ( "cursor", "pointer" ) | |
, ( "font-family", "menlo, monospace" ) | |
] | |
view : Model -> Html.Html Msg | |
view model = | |
let | |
credentials = | |
div [ style boxStyle ] | |
[ input | |
[ Attrs.value model.credentials | |
, Attrs.autocomplete False | |
, Attrs.placeholder "Client secret (go grab it from db)" | |
, Attrs.name "credentials" | |
, onInput SetCredentials | |
, style | |
[ ( "width", "50%" ) | |
, ( "font-family", "menlo, monospace" ) | |
, ( "font-size", "12px" ) | |
] | |
] | |
[] | |
, button [ onClick FetchServices ] [ text "Fetch services" ] | |
] | |
services = | |
case model.services of | |
Nothing -> | |
text "" | |
Just svcs -> | |
renderServices svcs model.serviceId | |
schema = | |
case model.schema of | |
Nothing -> | |
text "" | |
Just schema -> | |
form [ onSubmit SubmitJob ] | |
[ renderSchema schema [] model.input schema | |
, div [ style boxStyle ] | |
[ button [ Attrs.type' "submit" ] [ text "Create Job" ] | |
] | |
] | |
job = | |
case model.job of | |
Nothing -> | |
text "" | |
Just j -> | |
div [ style boxStyle ] | |
[ div [ style entityRowStyle ] | |
[ text ("Job " ++ j.id ++ ": " ++ j.state) | |
] | |
] | |
in | |
div [] | |
[ credentials | |
, services | |
, schema | |
, job | |
, text model.error | |
] | |
traverse : Schema -> List String -> Maybe Schema | |
traverse schema path = | |
let | |
getDefinition (Properties defs) name = | |
List.foldl | |
(\( n, prop ) result -> | |
if name == n then | |
Just prop | |
else | |
result | |
) | |
Nothing | |
defs | |
in | |
case path of | |
section :: name :: [] -> | |
case section of | |
"definitions" -> | |
getDefinition schema.definitions name | |
_ -> | |
Nothing | |
_ -> | |
Nothing | |
renderSchema : Schema -> List String -> InputData -> Schema -> Html.Html Msg | |
renderSchema schema path inputData rootSchema = | |
let | |
renderRow : ( String, Schema ) -> Html.Html Msg | |
renderRow ( name, property ) = | |
let | |
digDefinition ref = | |
String.split "/" ref | |
|> List.drop 1 | |
|> traverse rootSchema | |
required = | |
Set.member name schema.required | |
expandedProperty = | |
case property.ref of | |
Nothing -> | |
Just property | |
Just ref -> | |
digDefinition ref | |
in | |
div [ style boxStyle ] | |
[ text | |
(if required then | |
"* " | |
else | |
"" | |
) | |
, text (name ++ ": ") | |
, renderProperty expandedProperty (path ++ [ name ]) inputData schema | |
] | |
renderProps (Properties props) = | |
List.map renderRow props | |
in | |
div [] (renderProps schema.properties) | |
renderProperty : Maybe Schema -> List String -> InputData -> Schema -> Html.Html Msg | |
renderProperty property path inputData schema = | |
case property of | |
Nothing -> | |
text ("Missing property definition: " ++ (String.join "/" path)) | |
Just prop -> | |
case prop.type' of | |
"string" -> | |
renderInput prop path inputData schema | |
"integer" -> | |
renderInput prop path inputData schema | |
"object" -> | |
renderSchema prop path inputData schema | |
_ -> | |
text ("Unknown property type: " ++ prop.type') | |
renderInput : Schema -> List String -> InputData -> Schema -> Html.Html Msg | |
renderInput property path inputData schema = | |
let | |
isRequired = | |
Set.member (Maybe.withDefault "" (List.head path)) schema.required | |
inputType = | |
case property.format of | |
Just "uri" -> | |
"url" | |
_ -> | |
case property.type' of | |
"integer" -> | |
"number" | |
_ -> | |
"text" | |
pattern = | |
case property.format of | |
Just "uuid" -> | |
"[0-9a-f]{8}-[0-9a-f]{4}-[1-5][0-9a-f]{3}-[89ab][0-9a-f]{3}-[0-9a-f]{12}" | |
_ -> | |
".*" | |
title = | |
case property.format of | |
Just "uuid" -> | |
"Enter UUID like: 6a6eb029-06d9-4d4f-b257-ada7233b6086" | |
Just "uri" -> | |
"Enter URL" | |
_ -> | |
"" | |
in | |
input | |
[ Attrs.required isRequired | |
-- , Attrs.name name | |
, Attrs.title title | |
, Attrs.pattern pattern | |
, Attrs.type' inputType | |
, onInput (UpdateProperty path) | |
, style [ ( "font-family", "menlo, monospace" ), ( "width", "100%" ) ] | |
, Attrs.value (getString inputData path property) | |
] | |
[] | |
getString : InputData -> List String -> Schema -> String | |
getString inputData path schema = | |
getValue path inputData | |
|> Decode.decodeValue string | |
|> Result.withDefault "" | |
getValue : List String -> InputData -> Value | |
getValue path inputData = | |
let | |
encodeDict dict = | |
Encode.object (Dict.toList dict) | |
valueDecoder = | |
Decode.oneOf | |
[ Decode.map (\s -> Encode.string s) string | |
, Decode.map (\d -> encodeDict d) | |
(Decode.dict (DecodeExtra.lazy (\_ -> valueDecoder))) | |
] | |
decodeDict val = | |
Decode.decodeValue (Decode.dict valueDecoder) val | |
|> Result.withDefault Dict.empty | |
in | |
case path of | |
head :: [] -> | |
inputData | |
|> Dict.get head | |
|> Maybe.withDefault (Encode.string "") | |
head :: tail -> | |
inputData | |
|> Dict.get head | |
|> Maybe.withDefault (Encode.object []) | |
|> decodeDict | |
|> getValue tail | |
[] -> | |
Encode.string "" | |
renderServices : List ServiceDescriptor -> Id -> Html.Html Msg | |
renderServices services id = | |
div [] | |
[ div [ style boxStyle ] | |
[ div [] | |
(services | |
|> List.map | |
(\svc -> | |
span | |
[ style | |
(entityRowStyle | |
++ [ ( "margin-right", "10px" ) | |
, ( "display", "inline-block" ) | |
, ( "font-weight", "bold" ) | |
, ( "background" | |
, if id == svc.id then | |
"black" | |
else | |
"lightgrey" | |
) | |
, ( "color" | |
, if id == svc.id then | |
"seashell" | |
else | |
"black" | |
) | |
] | |
) | |
, onClick (FetchSchema svc.id) | |
] | |
[ text (svc.name) ] | |
) | |
) | |
] | |
] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment