From ccb7fdfe9914f47cc38f96e5973851f2c6f0c4b6 Mon Sep 17 00:00:00 2001 From: Greg Burri Date: Mon, 21 Apr 2008 21:48:22 +0000 Subject: [PATCH] =?utf8?q?MOD=20Passage=20au=20JSON=20(tout=20cass=C3=A9?= =?utf8?q?=20pour=20l'instant)?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- doc/TODO.txt | 2 +- doc/protocole3.txt | 32 +- js/euphorik.js | 5 +- modules/Makefile | 9 +- modules/erl/euphorik_protocole.erl | 188 ++++---- modules/erl/euphorik_requests.erl | 95 ++-- modules/erl/json.erl | 709 ----------------------------- 7 files changed, 180 insertions(+), 860 deletions(-) delete mode 100644 modules/erl/json.erl diff --git a/doc/TODO.txt b/doc/TODO.txt index 0916aef..2f732f1 100755 --- a/doc/TODO.txt +++ b/doc/TODO.txt @@ -1,7 +1,7 @@ == TODO == === v1.0 === -[80%] Conversations : +[ok] Conversations : [ok] implémenter coté serveur et client la sauvegarde et la restauration des conversations [ok] Supprimer l'envoie de la description des conversations lors du refresh ainsi que modifié la manière de créer les conversations (maj des diagrammes de séquence) [ok] Navigation vers les pages précédentes diff --git a/doc/protocole3.txt b/doc/protocole3.txt index 212794b..c3c2e6a 100644 --- a/doc/protocole3.txt +++ b/doc/protocole3.txt @@ -29,6 +29,19 @@ c : client s : server Les messages client vers serveur sont envoyés par HTTP-POST. +A toutes les requêtes le serveur peut répondre une erreur : + + { + "reply" : "error", + "error_message" : "blabla" + } + +Message ok générique : + + { + "reply" : "ok" + } + C.1. Login ---------- @@ -55,7 +68,7 @@ ou s -> c { "reply" : "login", - "status" : "registration_ok" | "authentification_ok" | "error", + "status" : "registration_ok" | "authentification_ok", "cookie" : "LKJDLAKSJBFLKASN", "id" : 193, "pseudo" : "Paul", @@ -68,8 +81,7 @@ s -> c "root" : 123, "page" : 1 } - ], - "error_message" : "blabla" + ] } @@ -84,7 +96,6 @@ c -> s C.3. Profile ------------ -Modification du profile, seul "cookie" est obligatoire. c -> s { @@ -95,7 +106,7 @@ c -> s "pseudo" : "Paul", "email" : "paul@pierre.com", "css" : "css/3/euphorik.css", - "mainPage" : 1, + "main_page" : 1, "conversations" : [ { "root" : 123, @@ -104,11 +115,10 @@ c -> s ] } -s -> c - { - "reply" : "ok" | "error", - "error_message" : "blabla" - } +s -> c + +ou + C.4. Wait event @@ -122,7 +132,7 @@ c -> s "cookie" : "LKJDLAKSJBFLKASN", "message_count" : 10, "last_message_id" : 163, - "mainPage" : 1, + "main_page" : 1, "conversations" : [ { "root" : 123, diff --git a/js/euphorik.js b/js/euphorik.js index bd0cd3a..f78e103 100755 --- a/js/euphorik.js +++ b/js/euphorik.js @@ -735,8 +735,9 @@ Client.prototype.connexion = function(action) success: function(data) { - thisClient.util.serializer.serializeToString(data).dump("Charger client") - thisClient.chargerDonnees(data) + //alert(data["error_message"]) + //thisClient.util.serializer.serializeToString(data).dump("Charger client") + //thisClient.chargerDonnees(data) } } ) diff --git a/modules/Makefile b/modules/Makefile index ec7ae48..80eef52 100755 --- a/modules/Makefile +++ b/modules/Makefile @@ -16,7 +16,6 @@ $(rep_ebin)/euphorik_minichat.beam \ $(rep_ebin)/euphorik_minichat_conversation.beam \ $(rep_ebin)/euphorik_requests.beam \ $(rep_ebin)/euphorik_protocole.beam \ -$(rep_ebin)/json.beam # Module pour la gestion de la BD, principalement la création $(rep_ebin)/euphorik_bd.beam: $(rep_erl)/euphorik_bd.erl $(rep_include)/euphorik_bd.hrl @@ -35,13 +34,9 @@ $(rep_ebin)/euphorik_requests.beam: $(rep_erl)/euphorik_requests.erl erlc $(erlc_params) # Module interpretant les messages XML du client -$(rep_ebin)/euphorik_protocole.beam: $(rep_erl)/euphorik_protocole.erl $(rep_erl)/json.erl +$(rep_ebin)/euphorik_protocole.beam: $(rep_erl)/euphorik_protocole.erl erlc $(erlc_params) -# Module json -$(rep_ebin)/json.beam: $(rep_erl)/json.erl - erlc $(erlc_params) - # Module pour la génération du captcha #$(rep_ebin)/captcha.beam: $(rep_erl)/captcha.erl # erlc $(erlc_params) @@ -52,4 +47,4 @@ $(rep_ebin)/json.beam: $(rep_erl)/json.erl # Suppression des modules compilés clean: - rm ebin/*.beam \ No newline at end of file + rm ebin/*.beam diff --git a/modules/erl/euphorik_protocole.erl b/modules/erl/euphorik_protocole.erl index 7e80308..40af2ea 100755 --- a/modules/erl/euphorik_protocole.erl +++ b/modules/erl/euphorik_protocole.erl @@ -13,7 +13,8 @@ logout/1, profile/1, refreshMessage/1, - message/1 + message/1, + erreur/1 ]). -include_lib("xmerl/include/xmerl.hrl"). @@ -21,9 +22,8 @@ -include("../include/euphorik_defines.hrl"). -% Une utilisateur s'enregistre avec un tuple {Login, Password}. -% @spec nouveau_user_login(xmerl:xmlElement()) -> string() -nouveau_user_login(Action) -> +% Une utilisateur s'enregistre avec un tuple {Login, Password}. +register([]) -> {Login, Password, Login_deja_pris} = case {xmerl_xpath:string("login", Action), xmerl_xpath:string("password", Action)} of {[#xmlElement{content = [#xmlText{value = L}]}], [#xmlElement{content = [#xmlText{value = P}]}]} -> {L, P, case euphorik_minichat:user_by_login(L) of {ok, _} -> true; _ -> false end}; @@ -40,28 +40,18 @@ nouveau_user_login(Action) -> ). -% Un utilisateur se logge. +% Un utilisateur se logge (avec un couple {login, mot de passe}) login([{login, Login}, {password, Password}]) -> - {ok, User} = euphorik_minichat:user_by_login_password(Login, Password), + loginUser(euphorik_minichat:user_by_login_password(Login, Password)); +% Un utilisateur se logge (avec un cookie) +login([{cookie, Cookie}]) -> + loginUser(euphorik_minichat:user_by_cookie(Cookie)). - -login(Action) -> - case xmerl_xpath:string("cookie", Action) of - [#xmlElement{content = [#xmlText{value = Cookie}]}] -> - loginUser(euphorik_minichat:user_by_cookie(Cookie)); - _ -> - case {xmerl_xpath:string("login", Action), xmerl_xpath:string("password", Action)} of - {[#xmlElement{content = [#xmlText{value = Login}]}], [#xmlElement{content = [#xmlText{value = Password}]}]} -> - loginUser(euphorik_minichat:user_by_login_password(Login, Password)); - _ -> - simple_xml_to_string(xml_reponse_login_pas_ok("XML malformé")) - end - end. loginUser({ok, User}) -> euphorik_minichat:update_date_derniere_connexion(User#user.id), - simple_xml_to_string(xml_reponse_login_ok(User)); + json_reponse_login_ok(User); loginUser(_) -> - simple_xml_to_string(xml_reponse_login_pas_ok("Erreur de login")). + erreur("Erreur login"). % Renvoie un string() représentant un cookie en base 36. Il y a 10^32 possibillités. @@ -77,48 +67,61 @@ logout(_) -> % Modification du profile. -profile(Action) -> - simple_xml_to_string( - case xmerl_xpath:string("cookie", Action) of - [#xmlElement{content = [#xmlText{value = Cookie}]}] -> - Login = case xmerl_xpath:string("login", Action) of [#xmlElement{content = [#xmlText{value = L}]}] -> L; _ -> undefined end, - Password = case xmerl_xpath:string("password", Action) of [#xmlElement{content = [#xmlText{value = P}]}] -> P; _ -> undefined end, - Pseudo = case xmerl_xpath:string("pseudo", Action) of [#xmlElement{content = [#xmlText{value = P2}]}] -> P2; _ -> Login end, - Email = case xmerl_xpath:string("email", Action) of [#xmlElement{content = [#xmlText{value = E}]}] -> E; _ -> undefined end, - Css = case xmerl_xpath:string("css", Action) of [#xmlElement{content = [#xmlText{value = C}]}] -> C; _ -> undefined end, - Page_principale = case xmerl_xpath:string("pagePrincipale", Action) of [#xmlElement{content = [#xmlText{value = P3}]}] -> list_to_integer(P3); _ -> undefined end, - Conversations = lists:foldr( - fun(Conv, Acc) -> - [#xmlElement{content = [#xmlText{value = Id_racine_str}]}] = xmerl_xpath:string("racine", Conv), - [#xmlElement{content = [#xmlText{value = Page_conv_str}]}] = xmerl_xpath:string("page", Conv), - Message_id = erlang:list_to_integer(Id_racine_str, 36), - % vérification de la validité de l'id - Message_existe = euphorik_minichat:message_existe(Message_id), - if Message_existe -> - [{Message_id, list_to_integer(Page_conv_str)} | Acc]; - true -> - Acc - end - end, - [], - xmerl_xpath:string("conversation", Action) - ), - case euphorik_minichat:set_profile(Cookie, Login, Password, Pseudo, Email, Css, Page_principale, Conversations) of - ok -> - xml_reponse_profile_ok(); - login_deja_pris -> - xml_reponse_profile_pas_ok("Login déjà pris"); - _ -> - xml_reponse_profile_pas_ok("Impossible de mettre à jour le profile") - end; - _ -> - xml_reponse_profile_pas_ok("XML malformé") - end - ). - +profile( + [ + {cookie, Cookie}, + {login, Login}, + {password, Password}, + {pseudo, Pseudo}, + {email, Email}, + {css, Css}, + {main_page, Main_page}, + {conversations, {array, Conversations_json}} + ] +) -> + % est-ce que les messages auquel on répond existent ? + Conversations = lists:foldr( + fun([struct, {root, Root}, {page, Page}], Acc) -> + Message_existe = euphorik_minichat:message_existe(Root), + if Message_existe -> + [{Root, Page} | Acc]; + true -> + Acc + end, + [], + Conversations_json + ), + case euphorik_minichat:set_profile(Cookie, Login, Password, Pseudo, Email, Css, Main_page, Conversations) of + ok -> + json_reponse_ok(); + login_deja_pris -> + erreur("Login déjà pris"); + _ -> + erreur("Impossible de mettre à jour le profile") + end. + % Renvoie les messages appropriés. -refreshMessage(Action) -> +wait_event( + [ + {cookie, Cookie}, + {message_count, Message_count} | Reste + ] +) -> + % Last message id est facultatif + Last_message_id = case lists:keysearch(last_message_id, 1, Reste) of + {Id, _} -> Id; + _ -> 0 + end, + {Main_page, _} = lists:keysearch(main_page, 1, Reste), + {{array, Conversations_json}, _} = lists:keysearch(conversations, 1, Reste), + User = euphorik_minichat:user_by_cookie(Cookie), + + + % TODO.... + + + simple_xml_to_string( case xmerl_xpath:string("nombreMessage", Action) of % le nombre de message qu'affiche le client [#xmlElement{content = [#xmlText{value = Nb_message_str}]}] -> @@ -236,6 +239,16 @@ message(Action) -> end ). + +% Construit une erreur +erreur(Message) -> + { + struct, [ + {reply, "error"}, + {error_message, Message} + ] + }. + % Formatage d'une heure % local_time() -> string @@ -257,10 +270,11 @@ format_date(Date) -> io_lib:format("~2.10.0B:~2.10.0B:~2.10.0B", [Heure, Minute, Seconde]). -%%%%%%%%% %%%%%%%%% -simple_xml_to_string(XML) -> - lists:flatten(xmerl:export_simple(XML, xmerl_xml, [{prolog, ["\n"]}])). +%%%%%%%%% %%%%%%%%% +json_reponse_ok() -> + {struct, [{status, "ok"}]}. + % Construit une réponse positive à un login % si Enregistre vaut true alors cela veut dire que la personne s'est enregistré (elle possède au moins un login et un password) @@ -290,6 +304,35 @@ xml_reponse_login_ok(User) -> }]. +json_reponse_login_ok(User) -> + { + struct, [ + {reply, "login"}, + {status, if (User#user.password =/= []) and (User#user.login =/= []) -> "enregistre"; true -> "identifie" end}, + {cookie, User#user.cookie}, + {id, User#user.id}, + {pseudo, User#user.pseudo}, + {login, User#user.login}, + {email, User#user.email}, + {css, User#user.css}, + {main_page, User#user.page_principale}, + {conversations, + {array, + lists:map( + fun(C) -> + {struct, + {root, element(1, C)}, + {page, element(2, C)} + } + end, + User#user.conversations + ) + } + } + ] + }. + + % Construit un réponse négative à un login xml_reponse_login_pas_ok(Message) -> [{reponse, [{name, "login"}], @@ -298,23 +341,6 @@ xml_reponse_login_pas_ok(Message) -> {information, [Message]} ] }]. - - -xml_reponse_profile_ok() -> - [{reponse, [{name, "profile"}], - [ - {statut, ["ok"]} - ] - }]. - - -xml_reponse_profile_pas_ok(Message) -> - [{reponse, [{name, "profile"}], - [ - {statut, ["pas ok"]}, - {information, [Message]} - ] - }]. % Pas utilisé diff --git a/modules/erl/euphorik_requests.erl b/modules/erl/euphorik_requests.erl index 2fb69c0..42348cf 100755 --- a/modules/erl/euphorik_requests.erl +++ b/modules/erl/euphorik_requests.erl @@ -15,24 +15,7 @@ % Test du module tester() -> - - %~ {XML2, _} = xmerl_scan:string( - %~ "" - %~ " 5DZQ2HCRO7JIX3QCSWRNL" - %~ ""), - %~ io:format("Login : ~p~n", [euphorik_protocole:login(XML2)]). - - XML = - "3FSDCH0FD4ML8WEPN2B5T" - "10" - "", - io:format("Messages de la premières page : ~p~n", [traiter_donnees(XML)]). - - %~ traiter_xml("" - %~ "4UDUSY6Z2IZNTQO484S8X" - %~ "Pifou" - %~ "test & plop" - %~ ""). + que_dal. % il faut catcher toutes les exceptions possibles @@ -40,44 +23,58 @@ out(A) -> %inet:setopts(A#arg.clisock, inet:getopts(A#arg.clisock, [active])), {value, {_, Contenu}} = lists:keysearch("action", 1, yaws_api:parse_post(A)), Ret = traiter_donnees(Contenu), - {content, "text/xml", Ret}. + %{content, "text/xml", Ret}. + {content, "application/json", Ret}. -traiter_donnees(Contenu) -> - case xmerl_scan:string(Contenu) of - {XML, _} -> - case XML of - #xmlElement{name = json, content = [#xmlText{value = J}|_]} -> - case json:decode_string(J) of - {ok, {struct, [{action, Action}| Reste]}} -> - traiter_action(Action, Reste); - _ -> - erreur - end; +traiter_donnees(Contenu) -> + % FIXME : ne plus encapsuler le JSON dans de l'xml... apparement yaws veux absolument de l'xml (voir post mi-avril 2008 sur la mailing list) + Reponse = case xmerl_scan:string(Contenu) of + {#xmlElement{name = json, content = [#xmlText{value = J}|_]}, _} -> + case json:decode_string(J) of + {ok, {struct, [{action, Action}| Reste]}} -> + %io:format("~p~n", [euphorik_protocole:login(JSON)]), + json:encode(traiter_action(Action, Reste)); _ -> - traiter_action(XML#xmlElement.attributes, XML) + error end; - _ -> erreur - end. - + _ -> error + end, + if Reponse =:= error -> + euphorik_protocole:erreur("Format XML/JSON incorrect"); + true -> + Reponse + end. + +% authentification d'un client traiter_action("authentification", JSON) -> - euphorik_protocole:login(JSON); + euphorik_protocole:login(JSON)); % un client s'enregistre (pseudo + password) +traiter_action("register", JSON) -> + euphorik_protocole:register(JSON); +% modification du profile +traiter_action("set_profile", JSON) -> + euphorik_protocole:profile(JSON); +% un utilisateur attend un événement (par exemple l'arrivé d'un nouveau message) +traiter_action("wait_event", JSON) -> + euphorik_protocole:wait_event(JSON); +% un utilisateur envoie un message +traiter_action("put_message", JSON) -> + euphorik_protocole:message(JSON). + + + + traiter_action([#xmlAttribute{value="register"}], XML) -> - euphorik_protocole:nouveau_user_login(XML); -% authentification d'un client -traiter_action([#xmlAttribute{value="login"}], XML) -> + euphorik_protocole:nouveau_user_login(XML); +traiter_action([#xmlAttribute{value="login"}], XML) -> euphorik_protocole:login(XML); -% modification du profile traiter_action([#xmlAttribute{value="profile"}], XML) -> - euphorik_protocole:profile(XML); -% un utilisateur demande les messages -traiter_action([#xmlAttribute{value="refreshMessages"}], XML) -> - euphorik_protocole:refreshMessage(XML); -% un utilisateur envoie un message -traiter_action([#xmlAttribute{value="message"}], XML) -> - euphorik_protocole:message(XML). - - - + euphorik_protocole:profile(XML); +traiter_action([#xmlAttribute{value="refreshMessages"}], XML) -> + euphorik_protocole:refreshMessage(XML); +% un utilisateur envoie un message +traiter_action([#xmlAttribute{value="message"}], XML) -> + euphorik_protocole:message(XML). + \ No newline at end of file diff --git a/modules/erl/json.erl b/modules/erl/json.erl deleted file mode 100644 index 585c05d..0000000 --- a/modules/erl/json.erl +++ /dev/null @@ -1,709 +0,0 @@ -%%% Copyright (c) 2005-2006, A2Z Development USA, Inc. All Rights Reserved. -%%% -%%% The contents of this file are subject to the Erlang Public License, -%%% Version 1.1, (the "License"); you may not use this file except in -%%% compliance with the License. You should have received a copy of the -%%% Erlang Public License along with this software. If not, it can be -%%% retrieved via the world wide web at http://www.erlang.org/. -%%% -%%% Software distributed under the License is distributed on an "AS IS" -%%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See -%%% the License for the specific language governing rights and limitations -%%% under the License. -%%% -%%% The Initial Developer of the Original Code is A2Z Development USA, Inc. -%%% All Rights Reserved. - --module(json). --export([encode/1, decode_string/1, decode/2]). --export([is_obj/1, obj_new/0, obj_fetch/2, obj_find/2, obj_is_key/2]). --export([obj_store/3, obj_from_list/1, obj_fold/3]). --export([test/0]). --author("Jim Larson , Robert Wai-Chi Chu "). --vsn("1"). - -%%% JavaScript Object Notation ("JSON", http://www.json.org) is a simple -%%% data syntax meant as a lightweight alternative to other representations, -%%% such as XML. JSON is natively supported by JavaScript, but many -%%% other languages have conversion libraries available. -%%% -%%% This module translates JSON types into the following Erlang types: -%%% -%%% JSON Erlang -%%% ---- ------ -%%% number number -%%% string string -%%% array tuple -%%% object tagged proplist with string (or atom) keys -%%% true, false, null atoms 'true', 'false', and 'null' -%%% -%%% Character Sets: the external representation, and the internal -%%% representation of strings, are lists of UTF-16 code units. -%%% The encoding of supplementary characters, as well as -%%% transcoding to other schemes, such as UTF-8, can be provided -%%% by other modules. (See discussion at -%%% http://groups.yahoo.com/group/json/message/52) -%%% -%%% Numbers: Thanks to Erlang's bignums, JSON-encoded integers of any -%%% size can be parsed. Conversely, extremely large integers may -%%% be JSON-encoded. This may cause problems for interoperability -%%% with JSON parsers which can't handle arbitrary-sized integers. -%%% Erlang's floats are of fixed precision and limited range, so -%%% syntactically valid JSON floating-point numbers could silently -%%% lose precision or noisily cause an overflow. However, most -%%% other JSON libraries are likely to behave in the same way. -%%% The encoding precision defaults to 6 digits. -%%% -%%% Strings: If we represented JSON string data as Erlang binaries, -%%% we would have to choose a particular unicode format. Instead, -%%% we use lists of UTF-16 code units, which applications may then -%%% change to binaries in their application-preferred manner. -%%% -%%% Arrays: Because of the string decision above, and Erlang's -%%% lack of a distinguished string datatype, JSON arrays map -%%% to Erlang tuples. Consider utilities like tuple_fold/3 -%%% to deal with tuples in their native form. -%%% -%%% Objects: Though not explicitly stated in the JSON "spec", -%%% JSON's JavaScript heritage mandates that member names must -%%% be unique within an object. The object/tuple ambiguity is -%%% not a problem, since the atom 'json_object' is not an -%%% allowable value. Object keys may be atoms or strings on -%%% encoding but are always decoded as strings. - -%%% ENCODING - -%% Encode an erlang number, string, tuple, or object to JSON syntax, as a -%% possibly deep list of UTF-16 code units, throwing a runtime error in the -%% case of un-convertible input. -%% Note: object keys may be either strings or atoms. - -encode(true) -> "true"; -encode(false) -> "false"; -encode(null) -> "null"; -encode(I) when is_integer(I) -> integer_to_list(I); -encode(F) when is_float(F) -> io_lib:format("~g", [F]); -encode(L) when is_list(L) -> encode_string(L); -encode({}) -> "[]"; -encode({json_object, Props} = T) when is_list(Props) -> encode_object(T); -encode(T) when is_tuple(T) -> encode_array(T); -encode(Bad) -> exit({json_encode, {bad_term, Bad}}). - -%% Encode an Erlang string to JSON. -%% Accumulate strings in reverse. - -encode_string(S) -> encode_string(S, [$"]). - -encode_string([], Acc) -> lists:reverse([$" | Acc]); -encode_string([C | Cs], Acc) -> - case C of - $" -> encode_string(Cs, [$", $\\ | Acc]); - % (don't escape solidus on encode) - $\\ -> encode_string(Cs, [$\\, $\\ | Acc]); - $\b -> encode_string(Cs, [$b, $\\ | Acc]); % note missing \ - $\f -> encode_string(Cs, [$f, $\\ | Acc]); - $\n -> encode_string(Cs, [$n, $\\ | Acc]); - $\r -> encode_string(Cs, [$r, $\\ | Acc]); - $\t -> encode_string(Cs, [$t, $\\ | Acc]); - C when C >= 0, C < $\s -> - % Control characters must be unicode-encoded. - Hex = lists:flatten(io_lib:format("~4.16.0b", [C])), - encode_string(Cs, lists:reverse(Hex) ++ "u\\" ++ Acc); - C when C =< 16#FFFF -> encode_string(Cs, [C | Acc]); - _ -> exit({json_encode, {bad_char, C}}) - end. - -%% Encode an Erlang object as a JSON object, allowing string or atom keys. -%% Note that order is irrelevant in both internal and external object -%% representations. Nevertheless, the output will respect the order -%% of the input. - -encode_object({json_object, _Props} = Obj) -> - M = obj_fold(fun({Key, Value}, Acc) -> - S = case Key of - L when is_list(L) -> encode_string(L); - A when is_atom(A) -> encode_string(atom_to_list(A)); - _ -> exit({json_encode, {bad_key, Key}}) - end, - V = encode(Value), - case Acc of - [] -> [S, $:, V]; - _ -> [Acc, $,, S, $:, V] - end - end, [], Obj), - [${, M, $}]. - -%% Encode an Erlang tuple as a JSON array. -%% Order *is* significant in a JSON array! - -encode_array(T) -> - M = tuple_fold(fun(E, Acc) -> - V = encode(E), - case Acc of - [] -> V; - _ -> [Acc, $,, V] - end - end, [], T), - [$[, M, $]]. - -%% A fold function for tuples (left-to-right). -%% Folded function takes arguments (Element, Accumulator). - -tuple_fold(F, A, T) when is_tuple(T) -> - tuple_fold(F, A, T, 1, size(T)). - -tuple_fold(_F, A, _T, I, N) when I > N -> - A; -tuple_fold(F, A, T, I, N) -> - A2 = F(element(I, T), A), - tuple_fold(F, A2, T, I + 1, N). - -%%% SCANNING -%%% -%%% Scanning funs return either: -%%% {done, Result, LeftOverChars} -%%% if a complete token is recognized, or -%%% {more, Continuation} -%%% if more input is needed. -%%% Result is {ok, Term}, 'eof', or {error, Reason}. -%%% Here, the Continuation is a simple Erlang string. -%%% -%%% Currently, error handling is rather crude - errors are recognized -%%% by match failures. EOF is handled only by number scanning, where -%%% it can delimit a number, and otherwise causes a match failure. -%%% -%%% Tokens are one of the following -%%% JSON string -> erlang string -%%% JSON number -> erlang number -%%% true, false, null -> erlang atoms -%%% { } [ ] : , -> lcbrace rcbrace lsbrace rsbrace colon comma - -token([]) -> {more, []}; -token(eof) -> {done, eof, []}; - -token("true" ++ Rest) -> {done, {ok, true}, Rest}; -token("tru") -> {more, "tru"}; -token("tr") -> {more, "tr"}; -token("t") -> {more, "t"}; - -token("false" ++ Rest) -> {done, {ok, false}, Rest}; -token("fals") -> {more, "fals"}; -token("fal") -> {more, "fal"}; -token("fa") -> {more, "fa"}; -token("f") -> {more, "f"}; - -token("null" ++ Rest) -> {done, {ok, null}, Rest}; -token("nul") -> {more, "nul"}; -token("nu") -> {more, "nu"}; -token("n") -> {more, "n"}; - -token([C | Cs] = Input) -> - case C of - $\s -> token(Cs); % eat whitespace - $\t -> token(Cs); % eat whitespace - $\n -> token(Cs); % eat whitespace - $\r -> token(Cs); % eat whitespace - $" -> scan_string(Input); - $- -> scan_number(Input); - D when D >= $0, D =< $9-> scan_number(Input); - ${ -> {done, {ok, lcbrace}, Cs}; - $} -> {done, {ok, rcbrace}, Cs}; - $[ -> {done, {ok, lsbrace}, Cs}; - $] -> {done, {ok, rsbrace}, Cs}; - $: -> {done, {ok, colon}, Cs}; - $, -> {done, {ok, comma}, Cs}; - $/ -> case scan_comment(Cs) of - {more, X} -> {more, X}; - {done, _, Chars} -> token(Chars) - end; - _ -> {done, {error, {bad_char, C}}, Cs} - end. - -scan_string([$" | Cs] = Input) -> - scan_string(Cs, [], Input). - -%% Accumulate in reverse order, save original start-of-string for continuation. - -scan_string([], _, X) -> {more, X}; -scan_string(eof, _, X) -> {done, {error, missing_close_quote}, X}; -scan_string([$" | Rest], A, _) -> {done, {ok, lists:reverse(A)}, Rest}; -scan_string([$\\], _, X) -> {more, X}; -scan_string([$\\, $u, U1, U2, U3, U4 | Rest], A, X) -> - scan_string(Rest, [uni_char([U1, U2, U3, U4]) | A], X); -scan_string([$\\, $u | _], _, X) -> {more, X}; -scan_string([$\\, C | Rest], A, X) -> - scan_string(Rest, [esc_to_char(C) | A], X); -scan_string([C | Rest], A, X) -> - scan_string(Rest, [C | A], X). - -%% Given a list of hex characters, convert to the corresponding integer. - -uni_char(HexList) -> - erlang:list_to_integer(HexList, 16). - -esc_to_char($") -> $"; -esc_to_char($/) -> $/; -esc_to_char($\\) -> $\\; -esc_to_char($b) -> $\b; -esc_to_char($f) -> $\f; -esc_to_char($n) -> $\n; -esc_to_char($r) -> $\r; -esc_to_char($t) -> $\t. - -scan_number([]) -> {more, []}; -scan_number(eof) -> {done, {error, incomplete_number}, []}; -scan_number([$- | Ds] = Input) -> - case scan_number(Ds) of - {more, _Cont} -> {more, Input}; - {done, {ok, N}, CharList} -> {done, {ok, -1 * N}, CharList}; - {done, Other, Chars} -> {done, Other, Chars} - end; -scan_number([D | Ds] = Input) when D >= $0, D =< $9 -> - scan_number(Ds, D - $0, Input). - -%% Numbers don't have a terminator, so stop at the first non-digit, -%% and ask for more if we run out. - -scan_number([], _A, X) -> {more, X}; -scan_number(eof, A, _X) -> {done, {ok, A}, eof}; -scan_number([$.], _A, X) -> {more, X}; -scan_number([$., D | Ds], A, X) when D >= $0, D =< $9 -> - scan_fraction([D | Ds], A, X); -scan_number([D | Ds], A, X) when A > 0, D >= $0, D =< $9 -> - % Note that nonzero numbers can't start with "0". - scan_number(Ds, 10 * A + (D - $0), X); -scan_number([D | Ds], A, X) when D == $E; D == $e -> - scan_exponent_begin(Ds, float(A), X); -scan_number([D | _] = Ds, A, _X) when D < $0; D > $9 -> - {done, {ok, A}, Ds}. - -scan_fraction(Ds, I, X) -> scan_fraction(Ds, [], I, X). - -scan_fraction([], _Fs, _I, X) -> {more, X}; -scan_fraction(eof, Fs, I, _X) -> - R = I + list_to_float("0." ++ lists:reverse(Fs)), - {done, {ok, R}, eof}; -scan_fraction([D | Ds], Fs, I, X) when D >= $0, D =< $9 -> - scan_fraction(Ds, [D | Fs], I, X); -scan_fraction([D | Ds], Fs, I, X) when D == $E; D == $e -> - R = I + list_to_float("0." ++ lists:reverse(Fs)), - scan_exponent_begin(Ds, R, X); -scan_fraction(Rest, Fs, I, _X) -> - R = I + list_to_float("0." ++ lists:reverse(Fs)), - {done, {ok, R}, Rest}. - -scan_exponent_begin(Ds, R, X) -> - scan_exponent_begin(Ds, [], R, X). - -scan_exponent_begin([], _Es, _R, X) -> {more, X}; -scan_exponent_begin(eof, _Es, _R, X) -> {done, {error, missing_exponent}, X}; -scan_exponent_begin([D | Ds], Es, R, X) when D == $-; - D == $+; - D >= $0, D =< $9 -> - scan_exponent(Ds, [D | Es], R, X). - -scan_exponent([], _Es, _R, X) -> {more, X}; -scan_exponent(eof, Es, R, _X) -> - X = R * math:pow(10, list_to_integer(lists:reverse(Es))), - {done, {ok, X}, eof}; -scan_exponent([D | Ds], Es, R, X) when D >= $0, D =< $9 -> - scan_exponent(Ds, [D | Es], R, X); -scan_exponent(Rest, Es, R, _X) -> - X = R * math:pow(10, list_to_integer(lists:reverse(Es))), - {done, {ok, X}, Rest}. - -scan_comment([]) -> {more, "/"}; -scan_comment(eof) -> {done, eof, []}; -scan_comment([$/ | Rest]) -> scan_cpp_comment(Rest); -scan_comment([$* | Rest]) -> scan_c_comment(Rest). - -%% Ignore up to next CR or LF. If the line ends in CRLF, -%% the LF will be treated as separate whitespace, which is -%% okay since it will also be ignored. - -scan_cpp_comment([]) -> {more, "//"}; -scan_cpp_comment(eof) -> {done, eof, []}; -scan_cpp_comment([$\r | Rest]) -> {done, [], Rest}; -scan_cpp_comment([$\n | Rest]) -> {done, [], Rest}; -scan_cpp_comment([_ | Rest]) -> scan_cpp_comment(Rest). - -scan_c_comment([]) -> {more, "/*"}; -scan_c_comment(eof) -> {done, eof, []}; -scan_c_comment([$*]) -> {more, "/**"}; -scan_c_comment([$*, $/ | Rest]) -> {done, [], Rest}; -scan_c_comment([_ | Rest]) -> scan_c_comment(Rest). - -%%% PARSING -%%% -%%% The decode function takes a char list as input, but -%%% interprets the end of the list as only an end to the available -%%% input, and returns a "continuation" requesting more input. -%%% When additional characters are available, they, and the -%%% continuation, are fed into decode/2. You can use the atom 'eof' -%%% as a character to signal a true end to the input stream, and -%%% possibly flush out an unfinished number. The decode_string/1 -%%% function appends 'eof' to its input and calls decode/1. -%%% -%%% Parsing and scanning errors are handled only by match failures. -%%% The external caller must take care to wrap the call in a "catch" -%%% or "try" if better error-handling is desired. Eventually parse -%%% or scan errors will be returned explicitly with a description, -%%% and someday with line numbers too. -%%% -%%% The parsing code uses a continuation-passing style to allow -%%% for the parsing to suspend at any point and be resumed when -%%% more input is available. -%%% See http://en.wikipedia.org/wiki/Continuation_passing_style - -%% Return the first JSON value decoded from the input string. -%% The string must contain at least one complete JSON value. - -decode_string(CharList) -> - {done, V, _} = decode([], CharList ++ eof), - V. - -%% Attempt to decode a JSON value from the input string -%% and continuation, using empty list for the initial continuation. -%% Return {done, Result, LeftoverChars} if a value is recognized, -%% or {more, Continuation} if more input characters are needed. -%% The Result can be {ok, Value}, eof, or {error, Reason}. -%% The Continuation is then fed as an argument to decode/2 when -%% more input is available. -%% Use the atom 'eof' instead of a char list to signal -%% a true end to the input, and may flush a final number. - -decode([], CharList) -> - decode(first_continuation(), CharList); - -decode(Continuation, CharList) -> - {OldChars, Kt} = Continuation, - get_token(OldChars ++ CharList, Kt). - -first_continuation() -> - {[], fun - (eof, Cs) -> - {done, eof, Cs}; - (T, Cs) -> - parse_value(T, Cs, fun(V, C2) -> - {done, {ok, V}, C2} - end) - end}. - -%% Continuation Kt must accept (TokenOrEof, Chars) - -get_token(Chars, Kt) -> - case token(Chars) of - {done, {ok, T}, Rest} -> Kt(T, Rest); - {done, eof, Rest} -> Kt(eof, Rest); - {done, {error, Reason}, Rest} -> {done, {error, Reason}, Rest}; - {more, X} -> {more, {X, Kt}} - end. - -%% Continuation Kv must accept (Value, Chars) - -parse_value(eof, C, _Kv) -> {done, {error, premature_eof}, C}; -parse_value(true, C, Kv) -> Kv(true, C); -parse_value(false, C, Kv) -> Kv(false, C); -parse_value(null, C, Kv) -> Kv(null, C); -parse_value(S, C, Kv) when is_list(S) -> Kv(S, C); -parse_value(N, C, Kv) when is_number(N) -> Kv(N, C); -parse_value(lcbrace, C, Kv) -> parse_object(C, Kv); -parse_value(lsbrace, C, Kv) -> parse_array(C, Kv); -parse_value(_, C, _Kv) -> {done, {error, syntax_error}, C}. - -%% Continuation Kv must accept (Value, Chars) - -parse_object(Chars, Kv) -> - get_token(Chars, fun(T, C2) -> - Obj = obj_new(), - case T of - rcbrace -> Kv(Obj, C2); % empty object - _ -> parse_object(Obj, T, C2, Kv) % token must be string - end - end). - -parse_object(_Obj, eof, C, _Kv) -> - {done, {error, premature_eof}, C}; - -parse_object(Obj, S, C, Kv) when is_list(S) -> % S is member name - get_token(C, fun - (colon, C2) -> - parse_object2(Obj, S, C2, Kv); - (T, C2) -> - {done, {error, {expecting_colon, T}}, C2} - end); - -parse_object(_Obj, M, C, _Kv) -> - {done, {error, {member_name_not_string, M}}, C}. - -parse_object2(Obj, S, C, Kv) -> - get_token(C, fun - (eof, C2) -> - {done, {error, premature_eof}, C2}; - (T, C2) -> - parse_value(T, C2, fun(V, C3) -> % V is member value - Obj2 = obj_store(S, V, Obj), - get_token(C3, fun - (rcbrace, C4) -> - Kv(Obj2, C4); % "}" end of object - (comma, C4) -> % "," another member follows - get_token(C4, fun(T3, C5) -> - parse_object(Obj2, T3, C5, Kv) - end); - (eof, C4) -> - {done, {error, premature_eof}, C4}; - (T2, C4) -> - {done, {error, {expecting_comma_or_curly, T2}}, C4} - end) - end) - end). - -%% Continuation Kv must accept (Value, Chars) - -parse_array(C, Kv) -> - get_token(C, fun - (eof, C2) -> {done, {error, premature_eof}, C2}; - (rsbrace, C2) -> Kv({}, C2); % empty array - (T, C2) -> parse_array([], T, C2, Kv) - end). - -parse_array(E, T, C, Kv) -> - parse_value(T, C, fun(V, C2) -> - E2 = [V | E], - get_token(C2, fun - (rsbrace, C3) -> % "]" end of array - Kv(list_to_tuple(lists:reverse(E2)), C3); - (comma, C3) -> % "," another value follows - get_token(C3, fun(T3, C4) -> - parse_array(E2, T3, C4, Kv) - end); - (eof, C3) -> - {done, {error, premature_eof}, C3}; - (T2, C3) -> - {done, {error, {expecting_comma_or_close_array, T2}}, C3} - end) - end). - -%%% OBJECTS -%%% -%%% We'll use tagged property lists as the internal representation -%%% of JSON objects. Unordered lists perform worse than trees for -%%% lookup and modification of members, but we expect objects to be -%%% have only a few members. Lists also print better. - -%% Is this a proper JSON object representation? - -is_obj({json_object, Props}) when is_list(Props) -> - lists:all(fun - ({Member, _Value}) when is_atom(Member); is_list(Member) -> true; - (_) -> false - end, Props); - -is_obj(_) -> - false. - -%% Create a new, empty object. - -obj_new() -> - {json_object, []}. - -%% Fetch an object member's value, expecting it to be in the object. -%% Return value, runtime error if no member found with that name. - -obj_fetch(Key, {json_object, Props}) when is_list(Props) -> - case proplists:get_value(Key, Props) of - undefined -> - exit({json_object_no_key, Key}); - Value -> - Value - end. - -%% Fetch an object member's value, or indicate that there is no such member. -%% Return {ok, Value} or 'error'. - -obj_find(Key, {json_object, Props}) when is_list(Props) -> - case proplists:get_value(Key, Props) of - undefined -> - error; - Value -> - {ok, Value} - end. - -obj_is_key(Key, {json_object, Props}) -> - proplists:is_defined(Key, Props). - -%% Store a new member in an object. Returns a new object. - -obj_store(Key, Value, {json_object, Props}) when is_list(Props) -> - {json_object, [{Key, Value} | proplists:delete(Key, Props)]}. - -%% Create an object from a list of Key/Value pairs. - -obj_from_list(Props) -> - Obj = {json_object, Props}, - case is_obj(Obj) of - true -> Obj; - false -> exit(json_bad_object) - end. - -%% Fold Fun across object, with initial accumulator Acc. -%% Fun should take (Value, Acc) as arguments and return Acc. - -obj_fold(Fun, Acc, {json_object, Props}) -> - lists:foldl(Fun, Acc, Props). - -%%% TESTING -%%% -%%% We can't expect to round-trip from JSON -> Erlang -> JSON, -%%% due to the degrees of freedom in the JSON syntax: whitespace, -%%% and ordering of object members. We can, however, expect to -%%% round-trip from Erlang -> JSON -> Erlang, so the JSON parsing -%%% tests will in fact test the Erlang equivalence of the -%%% JSON -> Erlang -> JSON -> Erlang coding chain. - -%% Test driver. Return 'ok' or {failed, Failures}. - -test() -> - E2Js = e2j_test_vec(), - Failures = lists:foldl(fun({E, J}, Fs) -> - case (catch test_e2j(E, J)) of - ok -> - case (catch round_trip(E)) of - ok -> - case (catch round_trip_one_char(E)) of - ok -> Fs; - Reason -> [{round_trip_one_char, E, Reason} | Fs] - end; - Reason -> - [{round_trip, E, Reason} | Fs] - end; - Reason -> - [{erlang_to_json, E, J, Reason} | Fs] - end; - (end_of_tests, Fs) -> Fs end, [], E2Js), - case Failures of - [] -> ok; - _ -> {failed, Failures} - end. - -%% Test for conversion from Erlang to JSON. Note that unequal strings -%% may represent equal JSON data, due to discretionary whitespace, -%% object member order, trailing zeroes in floating point, etc. -%% Legitimate changes to the encoding routines may require tweaks to -%% the reference JSON strings in e2j_test_vec(). - -test_e2j(E, J) -> - J2 = lists:flatten(encode(E)), - J = J2, % raises error if unequal - ok. - -%% Test that Erlang -> JSON -> Erlang round-trip yields equivalent term. - -round_trip(E) -> - J2 = lists:flatten(encode(E)), - {ok, E2} = decode_string(J2), - true = equiv(E, E2), % raises error if false - ok. - -%% Round-trip with one character at a time to test all continuations. - -round_trip_one_char(E) -> - J = lists:flatten(encode(E)), - {done, {ok, E2}, _} = lists:foldl(fun(C, Ret) -> - case Ret of - {done, _, _} -> Ret; - {more, Cont} -> decode(Cont, [C]) - end - end, {more, first_continuation()}, J ++ [eof]), - true = equiv(E, E2), % raises error if false - ok. - -%% Test for equivalence of Erlang terms. -%% Due to arbitrary order of construction, equivalent objects might -%% compare unequal as erlang terms, so we need to carefully recurse -%% through aggregates (tuples and objects). - -equiv({json_object, Props1}, {json_object, Props2}) -> - equiv_object(Props1, Props2); -equiv(T1, T2) when is_tuple(T1), is_tuple(T2) -> - equiv_tuple(T1, T2); -equiv(N1, N2) when is_number(N1), is_number(N2) -> N1 == N2; -equiv(S1, S2) when is_list(S1), is_list(S2) -> S1 == S2; -equiv(true, true) -> true; -equiv(false, false) -> true; -equiv(null, null) -> true. - -%% Object representation and traversal order is unknown. -%% Use the sledgehammer and sort property lists. - -equiv_object(Props1, Props2) -> - L1 = lists:keysort(1, Props1), - L2 = lists:keysort(1, Props2), - Pairs = lists:zip(L1, L2), - true = lists:all(fun({{K1, V1}, {K2, V2}}) -> - equiv(K1, K2) and equiv(V1, V2) - end, Pairs). - -%% Recursively compare tuple elements for equivalence. - -equiv_tuple({}, {}) -> - true; -equiv_tuple(T1, T2) when size(T1) == size(T2) -> - S = size(T1), - lists:all(fun(I) -> - equiv(element(I, T1), element(I, T2)) - end, lists:seq(1, S)). - -e2j_test_vec() -> [ - {1, "1"}, - {3.1416, "3.14160"}, % text representation may truncate, trail zeroes - {-1, "-1"}, - {-3.1416, "-3.14160"}, - {12.0e10, "1.20000e+11"}, - {1.234E+10, "1.23400e+10"}, - {-1.234E-10, "-1.23400e-10"}, - {"foo", "\"foo\""}, - {"foo" ++ [500] ++ "bar", [$", $f, $o, $o, 500, $b, $a, $r, $"]}, - {"foo" ++ [5] ++ "bar", "\"foo\\u0005bar\""}, - {"", "\"\""}, - {[], "\"\""}, - {"\n\n\n", "\"\\n\\n\\n\""}, - {obj_new(), "{}"}, - {obj_from_list([{"foo", "bar"}]), "{\"foo\":\"bar\"}"}, - {obj_from_list([{"foo", "bar"}, {"baz", 123}]), - "{\"foo\":\"bar\",\"baz\":123}"}, - {{}, "[]"}, - {{{}}, "[[]]"}, - {{1, "foo"}, "[1,\"foo\"]"}, - - % json array in a json object - {obj_from_list([{"foo", {123}}]), - "{\"foo\":[123]}"}, - - % json object in a json object - {obj_from_list([{"foo", obj_from_list([{"bar", true}])}]), - "{\"foo\":{\"bar\":true}}"}, - - % fold evaluation order - {obj_from_list([{"foo", {}}, - {"bar", obj_from_list([{"baz", true}])}, - {"alice", "bob"}]), - "{\"foo\":[],\"bar\":{\"baz\":true},\"alice\":\"bob\"}"}, - - % json object in a json array - {{-123, "foo", obj_from_list([{"bar", {}}]), null}, - "[-123,\"foo\",{\"bar\":[]},null]"}, - - end_of_tests -]. - -%%% TODO: -%%% -%%% Measure the overhead of the CPS-based parser by writing a conventional -%%% scanner-parser that expects all input to be available. -%%% -%%% JSON has dropped comments - disable their parsing. -%%% -%%% Allow a compile-time option to decode object member names as atoms, -%%% to reduce the internal representation overheads when communicating -%%% with trusted peers. -- 2.43.0