Files
Site_web/exercices/save_results.asp

214 lines
8.4 KiB
Plaintext

<%@ Language="VBScript" %>
<%
' ============================================================
' save_results.asp
' Reçoit les réponses de l'exercice TP Nuisibles (JSON en POST)
' et les enregistre dans la base SQL Server.
' ============================================================
Response.Buffer = True
Response.ContentType = "application/json"
Response.CharSet = "UTF-8"
' ------- À ADAPTER : chaîne de connexion vers votre base -------
' Récupérée depuis le panneau "Manage Databases" de FreeASPHosting :
' Server Name : sql.bsite.net\MSSQL2016
' SQL Username : nextgnformation_reponses_exercices
' Database name : (généralement identique au username, à vérifier dans le panneau)
Dim connString
connString = "Provider=SQLOLEDB;Data Source=sql.bsite.net\MSSQL2016;" & _
"Initial Catalog=nextgnformation_reponses_exercices;" & _
"User ID=nextgnformation_reponses_exercices;" & _
"Password=S5$NyFXzEjJCg6jD;"
' -----------------------------------------------------------------
Function JSONEscape(s)
s = Replace(s, "\", "\\")
s = Replace(s, Chr(34), "\""")
s = Replace(s, vbCrLf, "\n")
s = Replace(s, vbLf, "\n")
s = Replace(s, vbCr, "\n")
s = Replace(s, vbTab, "\t")
JSONEscape = s
End Function
Sub SendJSON(success, message)
Dim out
out = "{""success"":" & LCase(CStr(success)) & ",""error"":""" & JSONEscape(message) & """}"
Response.Write out
Response.End
End Sub
' --- Lecture du corps de la requête (JSON brut envoyé en POST) ---
Dim rawJSON
Dim totalBytes
totalBytes = Request.TotalBytes
If totalBytes = 0 Then
SendJSON False, "Aucune donnée reçue."
End If
Dim binData
binData = Request.BinaryRead(totalBytes)
' Conversion des octets UTF-8 en chaîne VBScript
Dim objStream
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1 ' adTypeBinary
objStream.Open
objStream.Write binData
objStream.Position = 0
objStream.Type = 2 ' adTypeText
objStream.CharSet = "utf-8"
rawJSON = objStream.ReadText
objStream.Close
Set objStream = Nothing
If Trim(rawJSON) = "" Then
SendJSON False, "Corps de requête vide."
End If
' --- Parsing JSON minimal sans librairie externe ---
' On utilise le moteur JScript via ScriptControl pour parser le JSON de façon fiable.
Dim sc
Set sc = Server.CreateObject("MSScriptControl.ScriptControl")
sc.Language = "JScript"
sc.AddCode "function parseIt(s){ return eval('(' + s + ')'); } " & _
"function getStr(o,k){ return (o && o[k] != null) ? String(o[k]) : ''; } " & _
"function getReponsesJSON(o){ var arr = o.reponses || []; var out = []; " & _
"for (var i=0;i<arr.length;i++){ out.push({id:String(arr[i].id||''), question:String(arr[i].question||''), reponse:String(arr[i].reponse||'')}); } return out; } " & _
"function getTableauJSON(o){ var arr = o.tp3_tableau || []; var out = []; " & _
"for (var i=0;i<arr.length;i++){ out.push({etape:String(arr[i].etape||''), risque:String(arr[i].risque||''), mesure:String(arr[i].mesure||'')}); } return out; }"
Dim dataObj
On Error Resume Next
Set dataObj = sc.Run("parseIt", rawJSON)
If Err.Number <> 0 Then
SendJSON False, "JSON invalide : " & Err.Description
End If
On Error Goto 0
Dim nom, dateSession, casChoisi, casCle, dateEnvoi
Dim metaIntitule, metaDescription, metaLieu, metaDebut, metaRealise, metaVerifie, metaMaj
nom = sc.Run("getStr", dataObj, "nom")
dateSession = sc.Run("getStr", dataObj, "date_session")
casChoisi = sc.Run("getStr", dataObj, "cas_choisi")
casCle = sc.Run("getStr", dataObj, "cas_cle")
dateEnvoi = sc.Run("getStr", dataObj, "date_envoi")
Dim tp3Obj
tp3Obj = dataObj.tp3_meta
metaIntitule = sc.Run("getStr", tp3Obj, "intitule")
metaDescription = sc.Run("getStr", tp3Obj, "description")
metaLieu = sc.Run("getStr", tp3Obj, "lieu")
metaDebut = sc.Run("getStr", tp3Obj, "debut")
metaRealise = sc.Run("getStr", tp3Obj, "realise_par")
metaVerifie = sc.Run("getStr", tp3Obj, "verifie_par")
metaMaj = sc.Run("getStr", tp3Obj, "maj_par")
If Trim(nom) = "" Then
SendJSON False, "Le nom du groupe est obligatoire."
End If
' --- Sérialisation des réponses et du tableau en JSON texte (stockés en colonnes NVARCHAR(MAX)) ---
Dim reponsesArr, tableauArr
Set reponsesArr = sc.Run("getReponsesJSON", dataObj)
Set tableauArr = sc.Run("getTableauJSON", dataObj)
Dim reponsesJSONStr, tableauJSONStr
reponsesJSONStr = "["
Dim i
For i = 0 To reponsesArr.length - 1
If i > 0 Then reponsesJSONStr = reponsesJSONStr & ","
reponsesJSONStr = reponsesJSONStr & "{""id"":""" & JSONEscape(reponsesArr.Item(i).id) & _
""",""question"":""" & JSONEscape(reponsesArr.Item(i).question) & _
""",""reponse"":""" & JSONEscape(reponsesArr.Item(i).reponse) & """}"
Next
reponsesJSONStr = reponsesJSONStr & "]"
tableauJSONStr = "["
For i = 0 To tableauArr.length - 1
If i > 0 Then tableauJSONStr = tableauJSONStr & ","
tableauJSONStr = tableauJSONStr & "{""etape"":""" & JSONEscape(tableauArr.Item(i).etape) & _
""",""risque"":""" & JSONEscape(tableauArr.Item(i).risque) & _
""",""mesure"":""" & JSONEscape(tableauArr.Item(i).mesure) & """}"
Next
tableauJSONStr = tableauJSONStr & "]"
' --- Connexion et insertion en base ---
Dim conn
Set conn = Server.CreateObject("ADODB.Connection")
On Error Resume Next
conn.Open connString
If Err.Number <> 0 Then
SendJSON False, "Connexion BDD impossible : " & Err.Description
End If
On Error Goto 0
' Création de la table si elle n'existe pas encore
Dim createTableSQL
createTableSQL = "IF NOT EXISTS (SELECT * FROM sysobjects WHERE name='tp_resultats' AND xtype='U') " & _
"CREATE TABLE tp_resultats (" & _
"id INT IDENTITY(1,1) PRIMARY KEY, " & _
"nom NVARCHAR(255), " & _
"date_session NVARCHAR(50), " & _
"cas_choisi NVARCHAR(255), " & _
"cas_cle NVARCHAR(100), " & _
"reponses_json NVARCHAR(MAX), " & _
"tp3_intitule NVARCHAR(500), " & _
"tp3_description NVARCHAR(1000), " & _
"tp3_lieu NVARCHAR(500), " & _
"tp3_debut NVARCHAR(50), " & _
"tp3_realise_par NVARCHAR(255), " & _
"tp3_verifie_par NVARCHAR(255), " & _
"tp3_maj_par NVARCHAR(255), " & _
"tp3_tableau_json NVARCHAR(MAX), " & _
"date_envoi NVARCHAR(50), " & _
"date_enregistrement DATETIME DEFAULT GETDATE())"
On Error Resume Next
conn.Execute createTableSQL
If Err.Number <> 0 Then
SendJSON False, "Création de table impossible : " & Err.Description
End If
On Error Goto 0
' Insertion via requête paramétrée (Command) pour éviter les injections SQL
Dim cmd
Set cmd = Server.CreateObject("ADODB.Command")
cmd.ActiveConnection = conn
cmd.CommandText = "INSERT INTO tp_resultats " & _
"(nom, date_session, cas_choisi, cas_cle, reponses_json, tp3_intitule, tp3_description, tp3_lieu, tp3_debut, tp3_realise_par, tp3_verifie_par, tp3_maj_par, tp3_tableau_json, date_envoi) " & _
"VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"
cmd.CommandType = 1 ' adCmdText
Dim p
Set p = cmd.CreateParameter("nom", 202, 1, 255, nom) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("date_session", 202, 1, 50, dateSession) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("cas_choisi", 202, 1, 255, casChoisi) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("cas_cle", 202, 1, 100, casCle) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("reponses_json", 203, 1, Len(reponsesJSONStr), reponsesJSONStr) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("tp3_intitule", 202, 1, 500, metaIntitule) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("tp3_description", 202, 1, 1000, metaDescription) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("tp3_lieu", 202, 1, 500, metaLieu) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("tp3_debut", 202, 1, 50, metaDebut) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("tp3_realise_par", 202, 1, 255, metaRealise) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("tp3_verifie_par", 202, 1, 255, metaVerifie) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("tp3_maj_par", 202, 1, 255, metaMaj) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("tp3_tableau_json", 203, 1, Len(tableauJSONStr), tableauJSONStr) : cmd.Parameters.Append p
Set p = cmd.CreateParameter("date_envoi", 202, 1, 50, dateEnvoi) : cmd.Parameters.Append p
On Error Resume Next
cmd.Execute
If Err.Number <> 0 Then
conn.Close
SendJSON False, "Erreur lors de l'insertion : " & Err.Description
End If
On Error Goto 0
conn.Close
Set conn = Nothing
SendJSON True, ""
%>