commit 820099ce7a26687b433f22e3ccbd8121086ff805 Author: Daniel Covington Date: Sun Oct 18 09:54:25 2026 -0400 init diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..dc5d4b8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +# Local tooling and generated runtime files +/.agents/ +/.github/ +/_bmad/ +/_bmad*/ +/logs/ +*.log +*.user +*.suo diff --git a/AGENTS.md b/AGENTS.md new file mode 100644 index 0000000..a6d4007 --- /dev/null +++ b/AGENTS.md @@ -0,0 +1,134 @@ +# PostcardMojo Agent Instructions + +## Role + +Act as an expert web developer, marketing strategist, and Classic ASP specialist. + +Build websites and features that are: + +- modern, polished, and visually credible +- easy to understand and use +- responsive across desktop, tablet, and mobile devices +- accessible and keyboard-friendly +- fast, secure, and maintainable +- written with clear marketing goals and useful calls to action +- appropriate for the PostcardMojo brand and its intended audience + +Combine sound engineering with strong user-experience and marketing judgment. +Do not focus on appearance alone. Consider clarity, trust, conversion, content +hierarchy, accessibility, performance, and the complete customer journey. + +## Technology + +This is a Classic ASP application using VBScript and the existing MVC +framework in this repository. + +Use the existing framework, its conventions, and its utilities to implement +all application features. Prefer the established project structure: + +- `public/` for the web entry point and public assets +- `app/controllers/` for request handling +- `app/views/` for presentation +- `app/models/` for application and domain data +- `app/services/` for business logic +- `app/repositories/` for persistence logic +- `db/migrations/` for database changes +- `core/` for the existing framework implementation + +Keep controllers thin. Keep business logic out of views. Keep database access +inside repositories and use parameterized queries for all untrusted values. +Encode dynamic HTML output and validate all request data on the server. + +## Framework Boundary + +Use the framework as it currently exists to complete work whenever reasonably +possible. Do not bypass, replace, or duplicate framework behavior with an +unrelated implementation. + +Treat `core/` as protected framework code. Do not modify, extend, replace, or +add framework code without the user's explicit approval. + +If a requested feature cannot be implemented correctly with the existing +framework: + +1. Explain what capability is missing. +2. Describe the effect on the requested feature. +3. Propose the smallest practical framework change or addition. +4. Identify the files that would be affected and any important risks or + tradeoffs. +5. Ask the user for permission before changing framework code. + +Do not treat silence as permission. Until approval is given, continue only +with work that does not require a framework change. + +Changes to application code outside `core/` do not require separate permission +when they are a normal part of the user's requested feature. + +## Required Code Generators + +Create all new controllers, database migrations, models, and repositories with +the existing generator scripts in `scripts/`. Do not create these files from +scratch or substitute a separate scaffolding process. + +Use the appropriate project script: + +- `scripts/generateController.vbs` for controllers +- `scripts/generateMigration.vbs` for database migrations +- `scripts/GenerateRepo.vbs` for models and repositories + +After generation, move generated files into the appropriate application +folder, then complete the normal framework wiring. This includes controller +autoloading, controller registration, route definitions, and any required +view or service integration. + +Generated code may be edited after creation to implement the requested feature, +but its initial structure must come from the relevant script. + +If a generator is missing, fails, or cannot express a required structure: + +1. Stop before manually creating the affected controller, migration, model, or + repository. +2. Explain the generator limitation or failure. +3. Recommend the smallest practical solution. +4. Ask the user for permission before manually creating the file or changing + the generator/framework. + +## Working Standards + +Before implementing a feature: + +1. Inspect the relevant framework and application code. +2. Reuse existing helpers and patterns before creating new ones. +3. Confirm that the planned work stays outside protected framework code. +4. Consider usability, accessibility, responsive behavior, security, SEO, and + the feature's marketing purpose. + +When implementing: + +- follow existing Classic ASP and VBScript conventions +- use explicit, descriptive names +- keep components focused and understandable +- preserve established routes and behavior unless a change is requested +- avoid unnecessary dependencies and external libraries +- never commit credentials, secrets, or environment-specific private data +- make application-level changes narrowly and deliberately + +After implementing: + +- inspect all changed ASP and VBScript for syntax and include-path errors +- verify controller registration and route wiring +- test the affected pages through IIS or IIS Express when available +- check responsive and accessible behavior for user-facing work +- report what changed, what was verified, and any remaining limitations + +## Decision Priority + +When making implementation decisions, prioritize: + +1. the user's explicit request +2. security and data integrity +3. the protected framework boundary +4. usability and accessibility +5. marketing effectiveness and brand clarity +6. maintainability and consistency with the existing application + diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..43c994c --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1 @@ +@AGENTS.md diff --git a/README.md b/README.md new file mode 100644 index 0000000..e29cf51 --- /dev/null +++ b/README.md @@ -0,0 +1,35 @@ +# PostcardMojo + +A clean Classic ASP application scaffold based on the RouteKit MVC framework. + +## Run locally + +1. Install IIS Express with Classic ASP enabled. +2. Run `run_site.cmd`. +3. Browse to `http://localhost:8080/`. + +The landing page is served by `HomeController.Index` through +`app/views/Home/landing.asp`. The earlier logo-reference page remains at +`app/views/Home/index.asp`. Requests enter through `public/Default.asp`. + +## Add an MVC feature + +1. Generate a controller: + `cscript //nologo scripts\generateController.vbs ExampleController "Index"` +2. Put the controller in `app/controllers/` and include it from + `app/controllers/autoload_controllers.asp`. +3. Register its name in `core/lib.ControllerRegistry.asp`. +4. Add its route in `public/Default.asp`. +5. Add any view files under `app/views/`. + +Optional generators are also provided for database migrations and repository +classes. Configure the connection string in `public/web.config` only when the +application needs a database. + +## Structure + +- `public/` — IIS site root and static assets +- `core/` — reusable MVC framework +- `app/` — application controllers, views, models, and repositories +- `db/migrations/` — application database migrations +- `scripts/` — generators and deployment utilities diff --git a/app/controllers/HomeController.asp b/app/controllers/HomeController.asp new file mode 100644 index 0000000..ebf00d4 --- /dev/null +++ b/app/controllers/HomeController.asp @@ -0,0 +1,26 @@ +<% +Class HomeController_Class + Public Title + Public useLayout + + Private Sub Class_Initialize() + Title = "PostcardMojo Logo Files" + useLayout = False + End Sub + + Public Sub Index() +%> + +<% + End Sub +End Class + +Dim HomeController_Class__Singleton +Function HomeController() + If IsEmpty(HomeController_Class__Singleton) Then + Set HomeController_Class__Singleton = New HomeController_Class + End If + + Set HomeController = HomeController_Class__Singleton +End Function +%> diff --git a/app/controllers/autoload_controllers.asp b/app/controllers/autoload_controllers.asp new file mode 100644 index 0000000..ebc1d93 --- /dev/null +++ b/app/controllers/autoload_controllers.asp @@ -0,0 +1 @@ + diff --git a/app/views/Home/index.asp b/app/views/Home/index.asp new file mode 100644 index 0000000..ea14dee --- /dev/null +++ b/app/views/Home/index.asp @@ -0,0 +1,263 @@ +PostcardMojo Logo Files + + + + +
+
+

postcardmojo logo files

+

Each logo as a transparent PNG (left) and a white-background JPG (right). Zoom in to look for compression artifacts. Switch to a dark background to see where the JPG's white box shows.

+
+
+ +
+
+ Background +
+ + + +
+
+
+ Zoom +
+ + + +
+
+
+ +
+

Full logo card icon with wordmark

+
+
+ +
+

Icon postcard mark only

+
+
+ +
+

PNGs are in images/logos/png/ and JPGs in images/logos/jpg/. Sizes are the actual pixel size of each file. The names come from the labels on the original sheet, which don't match the real sizes.

+

At 2× and 4×, scrolling one panel scrolls its partner too, so both show the same spot.

+
+
+ + diff --git a/app/views/Home/landing.asp b/app/views/Home/landing.asp new file mode 100644 index 0000000..2993c1a --- /dev/null +++ b/app/views/Home/landing.asp @@ -0,0 +1,276 @@ +<% +Response.Charset = "utf-8" +Response.CodePage = 65001 +%> + + + + + + PostcardMojo | Big Local Reach on One 9×12 Postcard + + + + + + + + + + + +
+
+ + PostcardMojo + + + Find your spot +
+
+ +
+
+ + +
+
+

Shared direct mail for local businesses

+

Make your business impossible to miss in the mailbox.

+

PostcardMojo puts a curated lineup of local businesses on one oversized 9×12 postcard. Your offer gets a bold, tangible place in nearby homes while participating businesses share the cost of printing and postage.

+
+ Explore a campaign + See how it works +
+
    +
  • Oversized 9×12 format
    • +
  • Built for neighborhood reach
    • +
  • Shared production costs
    • +
+
+ +
+ +
+
+ THE LOCAL EDITION + 9 × 12 +
+
+ + Big local offers.
One memorable mailer. +
+ +
A collection of businesses worth knowing
+
+
One card. Multiple businesses. A whole neighborhood of opportunity.
+
+
+
+ +
+
+
9 × 12Oversized presence
+
One cardA curated local lineup
+
SharedPrint and postage costs
+
LocalCampaign-focused reach
+
+
+ +
+
+
+

Simple by design

+

From your offer to their mailbox.

+

PostcardMojo turns a group of complementary local businesses into one well-organized, high-visibility mail piece.

+
+
    +
  1. + 01 + +

    Choose your campaign

    +

    Start with the local area and timing that fit your business goals.

    +
    2. +
  2. + 02 + +

    Claim your category

    +

    Reserve a space for your type of business, subject to campaign availability.

    +
    3. +
  3. + 03 + +

    Shape the offer

    +

    Bring your logo, message, and promotion together in a clear, focused ad.

    +
    4. +
  4. + 04 + +

    Reach the mailbox

    +

    The finished postcard is printed and mailed as one coordinated campaign.

    +
    5. +
+
+
+ +
+
+
+

A physical advantage

+

Digital ads disappear with a swipe. A great postcard gets held.

+

PostcardMojo gives your business a physical moment with a local customer. The oversized format creates room for a useful offer, recognizable branding, and a direct next step.

+ Put your offer on the next card +
+
+
+ 01 +

Big enough to notice

A 9×12 card has the visual presence to stand apart from ordinary envelopes and smaller mail pieces.

+
+
+ 02 +

Local enough to matter

Campaigns can be centered on the communities where participating businesses want to be known.

+
+
+ 03 +

Shared without feeling small

Businesses share the mail piece while each ad keeps its own message, offer, and brand identity.

+
+
+ 04 +

Easy to act on

A phone number, URL, QR code, or offer gives recipients a simple way to take the next step.

+
+
+
+
+ +
+
+
+
+

Made for the neighborhood

+

Local businesses belong in local mailboxes.

+
+

If nearby households can become customers, a PostcardMojo campaign can help introduce your business and give them a reason to respond.

+
+
+
+ +

Home services

+

Landscaping, cleaning, roofing, HVAC, plumbing, remodeling, and other trusted pros.

+
+
+ +

Health & wellness

+

Dentists, chiropractors, fitness studios, salons, spas, and wellness providers.

+
+
+ +

Food & experiences

+

Restaurants, cafés, entertainment, family activities, and places worth discovering.

+
+
+ +

Professional services

+

Real estate, insurance, financial, legal, pet care, automotive, and local experts.

+
+
+
+
+ +
+
+ +
+

Make the space count

+

A clear offer turns attention into action.

+

Your ad does not need to tell your whole story. It needs to make one strong promise and give a nearby customer one easy next step.

+
    +
  • ✓
    A direct headlineSay what you do and why it matters.
    • +
  • ✓
    A compelling reason to respondFeature an offer, service, or timely benefit.
    • +
  • ✓
    A simple call to actionUse a memorable URL, phone number, or QR code.
    • +
+
+
+
+ +
+
+
+

The short version

+

Questions before you join the card?

+

Every campaign is shaped around its participating businesses and selected local area. These answers cover the basics.

+
+
+
+ What is a shared 9×12 postcard? +

It is one oversized mail piece featuring a curated collection of local business ads. The format gives recipients multiple useful offers while advertisers share print and mailing costs.

+
+
+ Will a direct competitor appear beside me? +

Category availability is managed by campaign. Ask about category placement and any available exclusivity when reserving your space.

+
+
+ Do I need a finished ad? +

Start with your logo, offer, contact details, and any brand assets you already have. Creative requirements and available assistance can be confirmed for your campaign.

+
+
+ Where will the postcard be mailed? +

Campaigns are planned around selected local areas. Exact geography, timing, and mailing details are confirmed before you reserve a spot.

+
+
+ What does a campaign cost? +

Pricing depends on the campaign, placement, and mailing plan. Request current details for the area you want to reach.

+
+
+
+
+ +
+
+ +
+

Your neighborhood is waiting

+

Put your business in the next mailbox moment.

+

Tell us what you do and where you want to be seen. We will help you explore the right PostcardMojo campaign.

+
+
+ Request campaign details + Campaign availability varies by area. +
+
+
+
+ + + + diff --git a/app/views/shared/footer.asp b/app/views/shared/footer.asp new file mode 100644 index 0000000..89fdb62 --- /dev/null +++ b/app/views/shared/footer.asp @@ -0,0 +1 @@ +<% ' Optional shared layout footer. %> diff --git a/app/views/shared/header.asp b/app/views/shared/header.asp new file mode 100644 index 0000000..4065872 --- /dev/null +++ b/app/views/shared/header.asp @@ -0,0 +1 @@ +<% ' Optional shared layout header. %> diff --git a/applicationhost.config b/applicationhost.config new file mode 100644 index 0000000..8d6b56d --- /dev/null +++ b/applicationhost.config @@ -0,0 +1,1030 @@ + + + + + + + + +
+
+
+
+
+
+
+
+ + + +
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ +
+
+ +
+
+
+
+
+
+ +
+
+
+
+
+ +
+
+
+ +
+
+ +
+
+ +
+
+
+ + +
+
+
+
+
+
+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/core/autoload_core.asp b/core/autoload_core.asp new file mode 100644 index 0000000..6b406b8 --- /dev/null +++ b/core/autoload_core.asp @@ -0,0 +1,23 @@ + + + + + + + +<% Dim router : Set router = GetObject("script:"& Server.MapPath("../Core/router.wsc") & "") %> + + + + + + + + + + + + + + + diff --git a/core/databaseConnection.asp b/core/databaseConnection.asp new file mode 100644 index 0000000..7d5e297 --- /dev/null +++ b/core/databaseConnection.asp @@ -0,0 +1,127 @@ +<% +'------------------------------------------------------------------------------ +' DatabaseConnection.Class.inc +' A singleton VBScript "factory" for ADODB.Connection to multiple databases +' Enhanced with separate error handling for creation and open operations +'------------------------------------------------------------------------------ + +' Singleton holder +Dim DatabaseConnection__Singleton +Set DatabaseConnection__Singleton = Nothing + +' Factory function +Function DatabaseConnection() + If DatabaseConnection__Singleton Is Nothing Then + Set DatabaseConnection__Singleton = New DatabaseConnection_Class + End If + Set DatabaseConnection = DatabaseConnection__Singleton +End Function + +'------------------------------------------------------------------------------ +' Class definition +'------------------------------------------------------------------------------ +Class DatabaseConnection_Class + Private conn ' holds the ADODB.Connection instance + + '---------------------------------------- + ' Connect to an Access (.mdb/.accdb) file + '---------------------------------------- + Public Function ConnectToAccessDatabase(dataSource, provider) + If IsEmpty(provider) Or provider = "" Then + provider = "Microsoft.Jet.OLEDB.4.0" + End If + Dim connStr + connStr = "Provider=" & provider & ";" & _ + "Data Source=" & dataSource & ";" & _ + "Persist Security Info=False;" + Set ConnectToAccessDatabase = Me.Connect(connStr) + End Function + + '---------------------------------------- + ' Connect to SQL Server + '---------------------------------------- + Public Function ConnectToSQLServer(server, database, uid, pwd, useTrusted) + Dim connStr + If useTrusted = True Then + connStr = "Provider=SQLOLEDB;" & _ + "Server=" & server & ";" & _ + "Database=" & database & ";" & _ + "Trusted_Connection=Yes;" + Else + connStr = "Provider=SQLOLEDB;" & _ + "Server=" & server & ";" & _ + "Database=" & database & ";" & _ + "User ID=" & uid & ";" & _ + "Password=" & pwd & ";" + End If + Set ConnectToSQLServer = Me.Connect(connStr) + End Function + + '---------------------------------------- + ' Connect via ODBC DSN + '---------------------------------------- + Public Function ConnectToODBC(dsnName, uid, pwd) + Dim connStr + connStr = "DSN=" & dsnName & ";" + If Not IsEmpty(uid) Then connStr = connStr & "UID=" & uid & ";" + If Not IsEmpty(pwd) Then connStr = connStr & "PWD=" & pwd & ";" + Set ConnectToODBC = Me.Connect(connStr) + End Function + + '---------------------------------------- + ' Generic Connect: opens and returns an ADODB.Connection + ' Includes separate handling for creation and open errors + '---------------------------------------- + Public Function Connect(connectionString) + On Error Resume Next + + ' Dispose previous connection if any + If Not conn Is Nothing Then + conn.Close + Set conn = Nothing + End If + + ' Create ADO Connection object + Set conn = Server.CreateObject("ADODB.Connection") + If conn Is Nothing Then + Err.Clear + On Error GoTo 0 + Err.Raise 50000, _ + "DatabaseConnection_Class.Connect", _ + "Could not create ADODB.Connection. Ensure ADO is installed and registered." + End If + + ' Clear any prior errors before opening + Err.Clear + + ' Open database connection + conn.Open connectionString + If Err.Number <> 0 Then + Dim lastErrNum, lastErrDesc + lastErrNum = Err.Number + lastErrDesc = Err.Description + Err.Clear + On Error GoTo 0 + Err.Raise lastErrNum, _ + "DatabaseConnection_Class.Connect", _ + "Failed to open connection (" & connectionString & _ + ") - Error " & lastErrNum & ": " & lastErrDesc + End If + + On Error GoTo 0 + Set Connect = conn + End Function + + '---------------------------------------- + ' Close & clean up + '---------------------------------------- + Public Sub Close() + On Error Resume Next + If Not conn Is Nothing Then + conn.Close + Set conn = Nothing + End If + On Error GoTo 0 + End Sub +End Class +%> diff --git a/core/helpers.asp b/core/helpers.asp new file mode 100644 index 0000000..ca87a1e --- /dev/null +++ b/core/helpers.asp @@ -0,0 +1,536 @@ +<% +Function QuoteValue(val) + if IsWrappedInSingleQuotes(val) then + QuoteValue = val + Exit Function + end if + Select Case VarType(val) + Case vbString + QuoteValue = "'" & Replace(val, "'", "''") & "'" + Case vbDate + if conn.Provider = "Microsoft.Jet.OLEDB.4.0" or conn.Provider = "Microsoft.ACE.OLEDB.12.0" then + QuoteValue = "#" & FormatDateTime(val, 0) & "#" + else + ' SQL Server + QuoteValue = "'" & FormatDateTime(val, 0) & "'" + end if + Case vbNull, vbEmpty + QuoteValue = "Null" + Case vbBoolean + ' Return boolean values without quotes + QuoteValue = "'" & CStr(val) & "'" + Case Else + If IsNumeric(val) Then + QuoteValue = CLng(val) + Else + QuoteValue = CStr(val) + End If + End Select +End Function + +Public Function GetAppSetting(key) + Dim cacheKey, xml, nodes, node, i + cacheKey = "AppSetting_" & key + + ' Check Application cache first for performance + If Not IsEmpty(Application(cacheKey)) Then + GetAppSetting = Application(cacheKey) + Exit Function + End If + + ' Load from web.config only if not cached + Set xml = Server.CreateObject("Microsoft.XMLDOM") + xml.Load(Server.MapPath("web.config")) + Set nodes = xml.selectNodes("//appSettings/add") + For i = 0 To nodes.Length - 1 + Set node = nodes.Item(i) + If node.getAttribute("key") = key Then + GetAppSetting = node.getAttribute("value") + ' Cache the value for subsequent requests + Application.Lock + Application(cacheKey) = GetAppSetting + Application.Unlock + Exit Function + End If + Next + GetAppSetting = "nothing" +End Function + +Public Sub ShowServerVariables + Dim varName, htmlTable + htmlTable = "" + htmlTable = htmlTable & "" + + ' Loop through all server variables + For Each varName In Request.ServerVariables + htmlTable = htmlTable & "" + htmlTable = htmlTable & "" + htmlTable = htmlTable & "" + htmlTable = htmlTable & "" + Next + + htmlTable = htmlTable & "
Variable NameValue
" & Server.HTMLEncode(varName) & "" & Server.HTMLEncode(Request.ServerVariables(varName)) & "
" + + ' Output the HTML table + Response.Write(htmlTable) +End Sub +'------------------------------------------------------------------------------ +' Utility: IIf Function for VBScript +' Usage: result = IIf(condition, trueValue, falseValue) +'------------------------------------------------------------------------------ +Function IIf(condition, trueValue, falseValue) + On Error Resume Next + If CBool(condition) Then + IIf = trueValue + Else + IIf = falseValue + End If + If Err.Number <> 0 Then + ' Optional: handle or log error in conversion/evaluation + Err.Clear + End If + On Error GoTo 0 +End Function + +'----------------------------- +' Utility: Generic Error Reporter +'----------------------------- +Public Sub ErrorCheck(context) + If Err.Number <> 0 Then + Dim errHtml + errHtml = "
" + errHtml = errHtml & "Error occurred" & IIf(Not IsEmpty(context) And context <> "", ": " & context, "") & "
" + errHtml = errHtml & "Time: " & Now() & "
" + errHtml = errHtml & "Number: " & Err.Number & "
" + errHtml = errHtml & "Description: " & Server.HTMLEncode(Err.Description) & "
" + If Len(Err.Source) > 0 Then + errHtml = errHtml & "Source: " & Server.HTMLEncode(Err.Source) & "
" + End If + errHtml = errHtml & "
" + Response.Write errHtml + Err.Clear + End If +End Sub + +'------------------------------------------------------------------------------ +' Utility: TrimQueryParams +' Removes everything from the first "?" or "&" onward. +' Usage: +' CleanPath = TrimQueryParams(rawPath) +'------------------------------------------------------------------------------ +Function TrimQueryParams(rawPath) + Dim posQ, posA, cutPos + + ' find the first occurrences of "?" and "&" + posQ = InStr(rawPath, "?") + posA = InStr(rawPath, "&") + + ' determine the earliest cut position (>0) + If posQ > 0 And posA > 0 Then + cutPos = IIf(posQ < posA, posQ, posA) + ElseIf posQ > 0 Then + cutPos = posQ + ElseIf posA > 0 Then + cutPos = posA + Else + cutPos = 0 + End If + + ' if found, return up to just before that char + If cutPos > 0 Then + TrimQueryParams = Left(rawPath, cutPos - 1) + Else + TrimQueryParams = rawPath + End If +End Function + +Sub Destroy(o) + if isobject(o) then + if not o is nothing then + on error resume next + o.close + on error goto 0 + set o = nothing + end if + end if +End Sub + + 'prepends indents + Private Sub puti(v) + put Spaces(m_indent) & v + End Sub + + Sub put(v) + Select Case typename(v) + Case "LinkedList_Class" : response.write join(v.TO_Array, ", ") + Case "DynamicArray_Class" : response.write JoinList(v) + Case "Variant()" : response.write join(v, ", ") + Case else : response.write v + End Select +End Sub + +Sub put_ + put "
" +End Sub + +Sub putl(v) + put v + put_ +End Sub +'--------------------------------------------------------------------------------------------------------------------- +'Wrapper for Server.HTMLEncode() -- makes it easier on the eyes when reading the HTML code +Function H(s) + If Not IsEmpty(s) and Not IsNull(s) then + H = Server.HTMLEncode(s) + Else + H = "" + End If +End Function + + +'======================================================================================================================= +' Adapted from Tolerable library +'======================================================================================================================= +' This subroutine allows us to ignore the difference +' between object and primitive assignments. This is +' essential for many parts of the engine. +Public Sub Assign(ByRef var, ByVal val) + If IsObject(val) Then + Set var = val + Else + var = val + End If +End Sub + +' This is similar to the ? : operator of other languages. +' Unfortunately, both the if_true and if_false "branches" +' will be evalauted before the condition is even checked. So, +' you'll only want to use this for simple expressions. +Public Function Choice(ByVal cond, ByVal if_true, ByVal if_false) + If cond Then + Assign Choice, if_true + Else + Assign Choice, if_false + End If +End Function + +' Allows single-quotes to be used in place of double-quotes. +' Basically, this is a cheap trick that can make it easier +' to specify Lambdas. +Public Function Q(ByVal input) + Q = Replace(input, "'", """") +End Function + +Function SurroundString(inputVar) + If VarType(inputVar) = vbString Then + SurroundString = """" & inputVar & """" + Else + SurroundString = inputVar + End If +End Function + +Function SurroundStringInArray(arr) + Dim i + For i = LBound(arr) To UBound(arr) + If IsString(arr(i)) Then + arr(i) = """" & arr(i) & """" + End If + Next + SurroundStringInArray = arr +End Function +'----------------------------------------------------------------------------------------------------------------------- +'Boolean type checkers +'Don't forget IsArray is built-in! +Function IsString(value) + IsString = Choice(typename(value) = "String", true, false) +End Function + +Function IsDict(value) + IsDict = Choice(typename(value) = "Dictionary", true, false) +End Function + +Function IsRecordset(value) + IsRecordset = Choice(typename(value) = "Recordset", true, false) +End Function + +Function IsLinkedList(value) + IsLinkedList = Choice(typename(value) = "LinkedList_Class", true, false) +End Function + +Function IsArray(value) + IsArray = Choice(typename(value) = "Variant()", true, false) +End Function + +'-------------------------------------------------------------------- +' Returns True when the named key is present in Session.Contents +' • Handles scalars (String, Integer, etc.), objects, Empty, and Null +'-------------------------------------------------------------------- +Function SessionHasKey(keyName) + 'Loop over the existing keys—Session.Contents is like a dictionary + Dim k + For Each k In Session.Contents + If StrComp(k, keyName, vbTextCompare) = 0 Then + SessionHasKey = True + Exit Function + End If + Next + SessionHasKey = False 'not found +End Function + +Function RenderObjectsAsTable(arr,boolUseTabulator) + Dim html, propNames, i, j, obj, val, pkName, isPk + + If IsEmpty(arr) Or Not IsArray(arr) Then + RenderObjectsAsTable = "" + Exit Function + End If + + Set obj = arr(0) + On Error Resume Next + propNames = obj.Properties + pkName = obj.PrimaryKey + On Error GoTo 0 + + If IsEmpty(propNames) Or Len(pkName) = 0 Then + RenderObjectsAsTable = "" + Exit Function + End If + + html = "
" & vbCrLf + html = html & "" & vbCrLf + html = html & " " & vbCrLf + For i = 0 To UBound(propNames) + html = html & " " & vbCrLf + Next + html = html & " " & vbCrLf + html = html & " " & vbCrLf + + For j = 0 To UBound(arr) + Set obj = arr(j) + html = html & " " & vbCrLf + For i = 0 To UBound(propNames) + val = GetDynamicProperty(obj, propNames(i)) + isPk = (StrComp(propNames(i), pkName, vbTextCompare) = 0) + + If IsNull(val) Or IsEmpty(val) Then + val = " " + ElseIf IsDate(val) Then + val = FormatDateTime(val, vbShortDate) + ElseIf VarType(val) = vbBoolean Then + val = IIf(val, "True", "False") + Else + val = CStr(val) + Dim maxLen : maxLen = CInt(GetAppSetting("TableCellMaxLength")) + If maxLen <= 0 Then maxLen = 90 + If Len(val) > maxLen Then + val = Left(val, maxLen - 3) & "..." + End If + val = Server.HTMLEncode(val) + End If + + If isPk and boolUseTabulator = False Then + val = "" & val & "" + End If + + html = html & " " & vbCrLf + Next + html = html & " " & vbCrLf + Next + + html = html & " " & vbCrLf & "
" & Server.HTMLEncode(propNames(i)) & "
" & val & "
" & vbCrLf & "
" + RenderObjectsAsTable = html +End Function + +Function RenderFormFromObject(obj) + Dim html, propNames, i, name, val, inputType + Dim pkName, tableName, checkedAttr + + On Error Resume Next + propNames = obj.Properties + pkName = obj.PrimaryKey + tableName = obj.TableName + On Error GoTo 0 + + If IsEmpty(propNames) Or Len(pkName) = 0 Then + RenderFormFromObject = "" + Exit Function + End If + + html = "
" & vbCrLf + + For i = 0 To UBound(propNames) + name = propNames(i) + val = GetDynamicProperty(obj, name) + + ' Handle nulls + If IsNull(val) Then val = "" + + ' Primary key → hidden input + If StrComp(name, pkName, vbTextCompare) = 0 Then + html = html & " " & vbCrLf + 'Continue For + End If + + html = html & "
" & vbCrLf + html = html & " " & vbCrLf + + Select Case True + Case VarType(val) = vbBoolean + checkedAttr = "" + If val = True Then checkedAttr = " checked" + html = html & " " & vbCrLf + + Case IsDate(val) + html = html & " " & vbCrLf + + Case IsNumeric(val) + html = html & " " & vbCrLf + + Case Len(val) > CInt(GetAppSetting("FormTextareaThreshold")) + html = html & " " & vbCrLf + + Case Else + html = html & " " & vbCrLf + End Select + + html = html & "
" & vbCrLf + Next + + html = html & " " & vbCrLf + html = html & "
" & vbCrLf + + RenderFormFromObject = html +End Function + + +Function GetDynamicProperty(obj, propName) + On Error Resume Next + Dim result + Execute "result = obj." & propName + If Err.Number <> 0 Then + result = "" + Err.Clear + End If + GetDynamicProperty = result + On Error GoTo 0 +End Function + +Function FormatDateForInput(val) + If IsDate(val) Then + Dim yyyy, mm, dd + yyyy = Year(val) + mm = Right("0" & Month(val), 2) + dd = Right("0" & Day(val), 2) + FormatDateForInput = yyyy & "-" & mm & "-" & dd + Else + FormatDateForInput = "" + End If +End Function + + +'------------------------------------------------------------- +' Returns obj. for any public VBScript class property +'------------------------------------------------------------- +Function GetObjProp(o, pName) + Dim tmp + ' Build a tiny statement like: tmp = o.UserID + Execute "tmp = o." & pName + GetObjProp = tmp +End Function + +Function GenerateSlug(title) + Dim slug + slug = LCase(title) ' Convert to lowercase + slug = Replace(slug, "&", "and") ' Replace ampersands + slug = Replace(slug, "'", "") ' Remove apostrophes + slug = Replace(slug, """", "") ' Remove quotes + slug = Replace(slug, "–", "-") ' Replace en dash + slug = Replace(slug, "—", "-") ' Replace em dash + slug = Replace(slug, "/", "-") ' Replace slashes + slug = Replace(slug, "\", "-") ' Replace backslashes + + ' Remove all non-alphanumeric and non-hyphen/space characters + Dim i, ch, clean + clean = "" + For i = 1 To Len(slug) + ch = Mid(slug, i, 1) + If (ch >= "a" And ch <= "z") Or (ch >= "0" And ch <= "9") Or ch = " " Or ch = "-" Then + clean = clean & ch + End If + Next + + ' Replace multiple spaces or hyphens with single hyphen + Do While InStr(clean, " ") > 0 + clean = Replace(clean, " ", " ") + Loop + clean = Replace(clean, " ", "-") + Do While InStr(clean, "--") > 0 + clean = Replace(clean, "--", "-") + Loop + + ' Trim leading/trailing hyphens + Do While Left(clean, 1) = "-" + clean = Mid(clean, 2) + Loop + Do While Right(clean, 1) = "-" + clean = Left(clean, Len(clean) - 1) + Loop + + GenerateSlug = clean +End Function + +Function GetRawJsonFromRequest() + Dim stream, rawJson + Set stream = Server.CreateObject("ADODB.Stream") + stream.Type = 1 ' adTypeBinary + stream.Open + stream.Write Request.BinaryRead(Request.TotalBytes) + stream.Position = 0 + stream.Type = 2 ' adTypeText + stream.Charset = "utf-8" + rawJson = stream.ReadText + stream.Close + Set stream = Nothing + + GetRawJsonFromRequest = rawJson +End Function + +Function Active(controllerName) + On Error Resume Next + If Replace(Lcase(router.Resolve(Request.ServerVariables("REQUEST_METHOD"), TrimQueryParams(Request.ServerVariables("HTTP_X_ORIGINAL_URL")))(0)),"controller","") = LCase(controllerName) Then + Active = "active" + Else + Active = "" + End If + On Error GoTo 0 +End Function + +'==================================================================== +' FormatDateForSql +' Converts a VBScript Date to a SQL Server-compatible string +' Output: 'YYYY-MM-DD HH:MM:SS' +'==================================================================== +Function FormatDateForSql(vbDate) + If IsNull(vbDate) Or vbDate = "" Then + FormatDateForSql = "NULL" + Exit Function + End If + + ' Ensure vbDate is a valid date + If Not IsDate(vbDate) Then + Err.Raise vbObjectError + 1000, "FormatDateForSql", "Invalid date: " & vbDate + End If + + Dim yyyy, mm, dd, hh, nn, ss + yyyy = Year(vbDate) + mm = Right("0" & Month(vbDate), 2) + dd = Right("0" & Day(vbDate), 2) + hh = Right("0" & Hour(vbDate), 2) + nn = Right("0" & Minute(vbDate), 2) + ss = Right("0" & Second(vbDate), 2) + + ' Construct SQL Server datetime literal + FormatDateForSql = "'" & yyyy & "-" & mm & "-" & dd & " " & hh & ":" & nn & ":" & ss & "'" +End Function + +%> \ No newline at end of file diff --git a/core/lib.Automapper.asp b/core/lib.Automapper.asp new file mode 100644 index 0000000..750bc3a --- /dev/null +++ b/core/lib.Automapper.asp @@ -0,0 +1,159 @@ +<% +'======================================================================================================================= +' AUTOMAPPER CLASS +'======================================================================================================================= + +'Side Effects: Since src and target are passed ByRef to reduce unnecessary copying, if src is a recordset then the +' current record pointer is modified using src.MoveFirst and src.MoveNext. The end result is the current +' record pointer ends the operation at src.EOF. + +Class Automapper_Class + Private m_src + Private m_target + Private m_statements + Private m_statements_count + + Private Property Get Src : set Src = m_src : End Property + Private Property Get Target : set Target = m_target : End Property + + Private Sub Class_Initialize + m_statements_count = -1 + ReDim m_statements(-1) + End Sub + + Private Sub ResetState + m_statements_count = -1 + ReDim m_statements(-1) + Set m_src = Nothing + Set m_target = Nothing + End Sub + + 'Maps all rs or object fields to corresponding fields in the specified class. + Public Function AutoMap(src_obj, target_obj) + Set AutoMap = FlexMap(src_obj, target_obj, empty) + End Function + + 'Only maps fields specified in the field_names array (array of strings). + 'If field_names is empty, attempts to map all fields from the passed rs or object. + Public Function FlexMap(src_obj, target_obj, field_names) + Set FlexMap = DynMap(src_obj, target_obj, field_names, empty) + End Function + + 'Only maps fields specified in the field_names array (array of strings). + 'If field_names is empty then src MUST be a recordset as it attempts to map all fields from the recordset. + 'Since there is no reflection in vbscript, there is no way around this short of pseudo-reflection. + Public Function DynMap(src_obj, target_obj, field_names, exprs) + SetSource src_obj + SetTarget target_obj + + dim field_name + dim field_idx 'loop counter + + if IsEmpty(field_names) then 'map everything + if typename(src_obj) = "Recordset" then + for field_idx = 0 to src_obj.Fields.Count - 1 + field_name = src_obj.Fields.Item(field_idx).Name + 'AddStatement field_name + AddStatement BuildStatement(field_name) + next + + elseif InStr(typename(src_obj), "Dictionary") > 0 then 'enables Scripting.Dictionary and IRequestDictionary for Request.Querystring and Request.Form + for each field_name in src_obj + AddStatement BuildStatement(field_name) + next + + elseif not IsEmpty(src_obj.Class_Get_Properties) then + dim props : props = src_obj.Class_Get_Properties + for field_idx = 0 to ubound(props) + field_name = props(field_idx) + 'AddStatement field_name + AddStatement BuildStatement(field_name) + next + + else 'some invalid type of object + Err.Raise 9, "Automapper.DynMap", "Cannot automatically map this source object. Expected recordset or object implementing Class_Get_Properties reflection, got: " & typename(src_obj) + end if + + else 'map only specified fields + for field_idx = lbound(field_names) to ubound(field_names) + field_name = field_names(field_idx) + 'AddStatement field_name + AddStatement BuildStatement(field_name) + next + end if + + dim exprs_idx + + if not IsEmpty(exprs) then + if typename(exprs) = "Variant()" then + for exprs_idx = lbound(exprs) to ubound(exprs) + 'field_name = exprs(exprs_idx) + 'AddStatement field_name + AddStatement exprs(exprs_idx) + next + else 'assume string or string-like default value + AddStatement exprs + end if + end if + + 'Can't pre-join the statements because if one fails the rest of them fail too... :( + 'dim joined_statements : joined_statements = Join(m_statements, " : ") + 'put joined_statements + + 'suspend errors to prevent failing when attempting to map a field that does not exist in the class + on error resume next + dim stmt_idx + for stmt_idx = 0 to ubound(m_statements) + Execute m_statements(stmt_idx) + next + on error goto 0 + + set DynMap = m_target + + ResetState + End Function + + + Private Sub SetSource(ByVal src_obj) + set m_src = src_obj + End Sub + + Private Sub SetTarget(ByVal target_obj) + if typename(target_obj) = "String" then + set m_target = eval("new " & target_obj) + else + set m_target = target_obj + end if + End Sub + + + 'Builds a statement and adds it to the internal statements array + Private Sub AddStatement(ByVal stmt) + m_statements_count = m_statements_count + 1 + ReDim Preserve m_statements(m_statements_count) + m_statements(m_statements_count) = stmt + End Sub + + Private Function BuildStatement(ByVal field_name) + dim result + if typename(m_src) = "Recordset" or InStr(typename(m_src), "Dictionary") > 0 then + result = "m_target." & field_name & " = m_src(""" & field_name & """)" + else + 'Funky magic... + 'If src.field_name is an object, ensure the set statement is used + if IsObject(eval("m_src." & field_name)) then + result = "set " + else + 'result = "m_target." & field_name & " = m_src." & field_name + end if + result = result & " m_target." & field_name & " = m_src." & field_name + end if + BuildStatement = result + End Function +End Class + + +Function Automapper() + Set Automapper = new Automapper_Class +End Function +%> diff --git a/core/lib.CDOEmail.asp b/core/lib.CDOEmail.asp new file mode 100644 index 0000000..e55a55f --- /dev/null +++ b/core/lib.CDOEmail.asp @@ -0,0 +1,155 @@ +<% + +' Class: CDOEmail +' Handles email creation and sending via CDO in VBScript +Class CDOEmail_Class + ' Public properties + Public From + Public Subject + Public Body + Public IsBodyHTML + Public SMTPServer + Public SMTPPort + Public SMTPUsername + Public SMTPPassword + Public SMTPUseSSL + + ' Private members + Private cfg + Private msg + Private dictRecipients + Private arrAttachments + + ' Initialize default values and objects + Private Sub Class_Initialize() + ' Create CDO configuration and message objects + Set cfg = Server.CreateObject("CDO.Configuration") + Set msg = Server.CreateObject("CDO.Message") + + ' Default SMTP settings + SMTPServer = "localhost" + SMTPPort = 25 + SMTPUsername = "" + SMTPPassword = "" + SMTPUseSSL = False + + ' Initialize recipient collections + Set dictRecipients = Server.CreateObject("Scripting.Dictionary") + dictRecipients.Add "TO", Array() + dictRecipients.Add "CC", Array() + dictRecipients.Add "BCC", Array() + + ' Initialize attachments dynamic array + ReDim arrAttachments(-1) + + ' Default message settings + From = "" + Subject = "" + Body = "" + IsBodyHTML = False + End Sub + + ' Add a recipient by type: "To", "Cc", or "Bcc" + Public Sub AddRecipient(recipientType, address) + Dim key, tmp + key = UCase(recipientType) + If Not dictRecipients.Exists(key) Then + Err.Raise vbObjectError + 1000, "CDOEmail", "Invalid recipient type: " & recipientType + End If + tmp = dictRecipients(key) + If UBound(tmp) < LBound(tmp) Then + ReDim tmp(0) + Else + ReDim Preserve tmp(UBound(tmp) + 1) + End If + tmp(UBound(tmp)) = address + dictRecipients(key) = tmp + End Sub + + ' Add a file attachment + Public Sub AddAttachment(filePath) + If UBound(arrAttachments) < LBound(arrAttachments) Then + ReDim arrAttachments(0) + Else + ReDim Preserve arrAttachments(UBound(arrAttachments) + 1) + End If + arrAttachments(UBound(arrAttachments)) = filePath + End Sub + + ' Send the email, returning True on success, False on failure + Public Function Send() + ' Configure SMTP settings + With cfg.Fields + .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 ' cdoSendUsingPort + .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer + .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPPort + .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = Choice(Len(SMTPUsername) > 0, 1, 0) ' cdoBasic or cdoAnonymous + .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SMTPUsername + .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SMTPPassword + .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = SMTPUseSSL + .Update + End With + + ' Apply configuration to message + Set msg.Configuration = cfg + + ' Populate message fields + msg.From = From + msg.Subject = Subject + If dictRecipients.Exists("TO") And UBound(dictRecipients("TO")) >= LBound(dictRecipients("TO")) Then + msg.To = Join(dictRecipients("TO"), ";") + End If + If dictRecipients.Exists("CC") And UBound(dictRecipients("CC")) >= LBound(dictRecipients("CC")) Then + msg.CC = Join(dictRecipients("CC"), ";") + End If + If dictRecipients.Exists("BCC") And UBound(dictRecipients("BCC")) >= LBound(dictRecipients("BCC")) Then + msg.BCC = Join(dictRecipients("BCC"), ";") + End If + + If IsBodyHTML Then + msg.HTMLBody = Body + Else + msg.TextBody = Body + End If + + ' Add attachments if any + Dim i + For i = LBound(arrAttachments) To UBound(arrAttachments) + msg.AddAttachment arrAttachments(i) + Next + + ' Send and handle errors + On Error Resume Next + msg.Send + errNum = Err.Number + errDesc = Err.Description + On Error Goto 0 + If Err.Number <> 0 Then + Response.Write "CDO Error #" & errNum & ": " & errDesc & "
" + Send = False + Err.Clear + Else + Send = True + End If + + End Function + + ' Clean up objects + Private Sub Class_Terminate() + On Error Resume Next + Set msg = Nothing + Set cfg = Nothing + Set dictRecipients = Nothing + Erase arrAttachments + End Sub +End Class + +dim CDOEmail_Class__Singleton +Function CDOEmail() + if IsEmpty(CDOEmail_Class__Singleton) then + set CDOEmail_Class__Singleton = new CDOEmail_Class + end if + set CDOEmail = CDOEmail_Class__Singleton +End Function + +%> diff --git a/core/lib.Collections.asp b/core/lib.Collections.asp new file mode 100644 index 0000000..60ad607 --- /dev/null +++ b/core/lib.Collections.asp @@ -0,0 +1,914 @@ +<% +'======================================================================================================================= +' KVArray +' Relatively painless implementation of key/value pair arrays without requiring a full Scripting.Dictionary COM instance. +' A KVArray is a standard array where element i is the key and element i+1 is the value. Loops must step by 2. +'======================================================================================================================= +'given a KVArray and key index, returns the key and value +'pre: kv_array has at least key_idx and key_idx + 1 values +'post: key and val are populated +Sub KeyVal(kv_array, key_idx, ByRef key, ByRef val) + if (key_idx + 1 > ubound(kv_array)) then err.raise 1, "KeyVal", "expected key_idx < " & ubound(kv_array) - 1 & ", got: " & key_idx + key = kv_array(key_idx) + val = kv_array(key_idx + 1) +End Sub + +'--------------------------------------------------------------------------------------------------------------------- +'Given a KVArray, a key and a value, appends the key and value to the end of the KVArray +Sub KVAppend(ByRef kv_array, key, val) + dim i : i = ubound(kv_array) + redim preserve kv_array(i + 2) + kv_array(i + 1) = key + kv_array(i + 2) = val +End Sub + +'----------------------------------------------------------------------------------------------------------------------- +'Given a KVArray and two variants, populates the first variant with all keys and the second variant with all values. +'If +'Pre: kv_array has at least key_idx and key_idx + 1 values +'Post: key_array contains all keys in kvarray. +' val_array contains all values in kvarray. +' key_array and val_array values are in corresponding order, i.e. key_array(i) corresponds to val_array(i). +Sub KVUnzip(kv_array, key_array, val_array) + dim kv_array_size : kv_array_size = ubound(kv_array) + dim num_pairs : num_pairs = (kv_array_size + 1) / 2 + dim result_array_size : result_array_size = num_pairs - 1 + + 'Extend existing key_array or create new array to hold the keys + If IsArray(key_array) then + redim preserve key_array(ubound(key_array) + result_array_size) + Else + key_array = Array() + redim key_array(result_array_size) + End If + + 'Extend existing val array or create new array to hold the values + If IsArray(val_array) then + redim preserve val_array(ubound(val_array) + result_array_size) + Else + val_array = Array() + redim val_array(num_pairs - 1) + End If + + 'Unzip the KVArray into the two output arrays + dim i, key, val + dim key_val_arrays_idx : key_val_arrays_idx = 0 ' used to sync loading the key_array and val_array + For i = 0 to ubound(kv_array) step 2 + KeyVal kv_array, i, key, val + key_array(key_val_arrays_idx) = key + val_array(key_val_arrays_idx) = val + key_val_arrays_idx = key_val_arrays_idx + 1 ' increment by 1 because loop goes to next pair in kv_array + Next +End Sub + +'--------------------------------------------------------------------------------------------------------------------- +'Given a KVArray, dumps it to the screen. Useful for debugging purposes. +Sub DumpKVArray(kv_array) + dim i, key, val + For i = 0 to ubound(kv_array) step 2 + KeyVal kv_array, i, key, val + put key & " => " & val & "
" + Next +End Sub + + +'======================================================================================================================= +' Pair Class +' Holds a pair of values, i.e. a key value pair, recordset field name/value pair, etc. +' Similar to the C++ STL std::pair class. Useful for some iteration and the like. +' +' This was an interesting idea but so far has not really been used, oh well...... +'======================================================================================================================= +Class Pair_Class + Private m_first, m_second + + Public Property Get First : First = m_first : End Property + Public Property Get [Second] : [Second] = m_second : End Property + + Public Default Property Get TO_String + TO_String = First & " " & [Second] + End Property + + Public Sub Initialize(ByVal firstval, ByVal secondval) + Assign m_first, firstval + Assign m_second, secondval + End Sub + + 'Swaps the two values + Public Sub Swap + dim tmp + Assign tmp, m_second + Assign m_second, m_first + Assign m_first, tmp + End Sub +End Class + +Function MakePair(ByVal firstval, ByVal secondval) + dim P : set P = new Pair_Class + P.Initialize firstval, secondval + set MakePair = P +End Function + + + +'======================================================================================================================= +' Linked List - From the Tolerable lib +'======================================================================================================================= +' This is just here for reference +Class Iterator_Class + Public Function HasNext() + End Function + + Public Function PeekNext() + End Function + + Public Function GetNext() + End Function + + + Public Function HasPrev() + End Function + + Public Function PeekPrev() + End Function + + Public Function GetPrev() + End Function +End Class + + +Class Enumerator_Source_Iterator_Class + Private m_iter + + Public Sub Initialize(ByVal iter) + Set m_iter = iter + End Sub + + Private Sub Class_Terminate() + Set m_iter = Nothing + End Sub + + Public Sub GetNext(ByRef retval, ByRef successful) + If m_iter.HasNext Then + Assign retval, m_iter.GetNext + successful = True + Else + successful = False + End If + End Sub +End Class + + +Public Function En_Iterator(ByVal iter) + Dim retval + Set retval = New Enumerator_Source_Iterator_Class + retval.Initialize iter + Set En_Iterator = Enumerator(retval) +End Function + + +Class LinkedList_Node_Class + Public m_prev + Public m_next + Public m_value + + Private Sub Class_Initialize() + Set m_prev = Nothing + Set m_next = Nothing + End Sub + + Private Sub Class_Terminate() + Set m_prev = Nothing + Set m_next = Nothing + Set m_value = Nothing + End Sub + + Public Sub SetValue(ByVal value) + Assign m_value, value + End Sub +End Class + + +Class Iterator_LinkedList_Class + Private m_left + Private m_right + + Public Sub Initialize(ByVal r) + Set m_left = Nothing + Set m_right = r + End Sub + + Private Sub Class_Terminate() + Set m_Left = Nothing + Set m_Right = Nothing + End Sub + + Public Function HasNext() + HasNext = Not(m_right Is Nothing) + End Function + + Public Function PeekNext() + Assign PeekNext, m_right.m_value + End Function + + Public Function GetNext() + Assign GetNext, m_right.m_value + Set m_left = m_right + Set m_right = m_right.m_next + End Function + + Public Function HasPrev() + HasPrev = Not(m_left Is Nothing) + End Function + + Public Function PeekPrev() + Assign PeekPrev, m_left.m_value + End Function + + Public Function GetPrev() + Assign GetPrev, m_left.m_value + Set m_right = m_left + Set m_left = m_left.m_prev + End Function +End Class + + +'----------------------------------------------------------------------------------------------------------------------- +Class LinkedList_Class + Private m_first + Private m_last + Private m_size + + Private Sub Class_Initialize() + Me.Reset + End Sub + + Private Sub Class_Terminate() + Me.Reset + End Sub + + Public Function Clear() + Set m_first = Nothing + Set m_last = Nothing + m_size = 0 + Set Clear = Me + End Function + + Private Function NewNode(ByVal value) + Dim retval + Set retval = New LinkedList_Node_Class + retval.SetValue value + Set NewNode = retval + End Function + + Public Sub Reset() + Set m_first = Nothing + Set m_last = Nothing + m_size = 0 + End Sub + + Public Function IsEmpty() + IsEmpty = (m_last Is Nothing) + End Function + + Public Property Get Count + Count = m_size + End Property + + 'I just like .Size better than .Count sometimes, sue me + Public Property Get Size + Size = m_size + End Property + + Public Function Iterator() + Dim retval + Set retval = New Iterator_LinkedList_Class + retval.Initialize m_first + Set Iterator = retval + End Function + + Public Function Push(ByVal value) + Dim temp + Set temp = NewNode(value) + If Me.IsEmpty Then + Set m_first = temp + Set m_last = temp + Else + Set temp.m_prev = m_last + Set m_last.m_next = temp + Set m_last = temp + End If + m_size = m_size + 1 + Set Push = Me + End Function + + + Public Function Peek() + ' TODO: Error handling + Assign Peek, m_last.m_value + End Function + + ' Alias for Peek + Public Function Back() + ' TODO: Error handling + Assign Back, m_last.m_value + End Function + + Public Function Pop() + Dim temp + + ' TODO: Error Handling + Assign Pop, m_last.m_value + + Set temp = m_last + Set m_last = temp.m_prev + Set temp.m_prev = Nothing + If m_last Is Nothing Then + Set m_first = Nothing + Else + Set m_last.m_next = Nothing + End If + m_size = m_size - 1 + End Function + + + + Public Function Unshift(ByVal value) + Dim temp + Set temp = NewNode(value) + If Me.IsEmpty Then + Set m_first = temp + Set m_last = temp + Else + Set temp.m_next = m_first + Set m_first.m_prev = temp + Set m_first = temp + End If + m_size = m_size + 1 + Set Unshift = Me + End Function + + + + ' Alias for Peek + Public Function Front() + ' TODO: Error handling + Assign Front, m_first.m_value + End Function + + Public Function Shift() + Dim temp + + ' TODO: Error Handling + Assign Shift, m_first.m_value + + Set temp = m_first + Set m_first = temp.m_next + Set temp.m_next = Nothing + If m_first Is Nothing Then + Set m_last = Nothing + Else + Set m_first.m_prev = Nothing + End If + m_size = m_size - 1 + End Function + + Public Function TO_Array() + Dim i, iter + + ReDim retval(Me.Count - 1) + i = 0 + Set iter = Me.Iterator + While iter.HasNext + assign retval(i),iter.GetNext + i = i + 1 + Wend + TO_Array = retval + End Function + + Public Function TO_En() + Set TO_En = En_Iterator(Iterator) + End Function + +End Class + + + + +'======================================================================================================================= +' Dynamic Array - From the Tolerable lib +'======================================================================================================================= +Class DynamicArray_Class + Private m_data + Private m_size + + Public Sub Initialize(ByVal d, ByVal s) + m_data = d + m_size = s + End Sub + + Private Sub Class_Terminate() + Set m_data = Nothing + End Sub + + + Public Property Get Capacity + Capacity = UBOUND(m_data) + 1 + End Property + + Public Property Get Count + Count = m_size + End Property + + ' Alias for Count + Public Property Get Size + Size = m_size + End Property + + Public Function IsEmpty() + IsEmpty = (m_size = 0) + End Function + + Public Function Clear() + m_size = 0 + Set Clear = Me + End Function + + Private Sub Grow + ' TODO: There's probably a better way to + ' do this. Doubling might be excessive + ReDim Preserve m_data(UBOUND(m_data) * 2) + End Sub + + Public Function Push(ByVal val) + If m_size >= UBOUND(m_data) Then + Grow + End If + Assign m_data(m_size), val + m_size = m_size + 1 + Set Push = Me + End Function + + + ' Look at the last element + Public Function Peek() + Assign Peek, m_data(m_size - 1) + End Function + + ' Look at the last element and + ' pop it off of the list + Public Function Pop() + Assign Pop, m_data(m_size - 1) + m_size = m_size - 1 + End Function + + + ' If pseudo_index < 0, then we assume we're counting + ' from the back of the Array. + Private Function CalculateIndex(ByVal pseudo_index) + If pseudo_index >= 0 Then + CalculateIndex = pseudo_index + Else + CalculateIndex = m_size + pseudo_index + End If + End Function + + Public Default Function Item(ByVal i) + Assign Item, m_data(CalculateIndex(i)) + End Function + + + ' This does not treat negative indices as wrap-around. + ' Thus, it is slightly faster. + Public Function FastItem(ByVal i) + Assign FastItem, m_data(i) + End Function + + + Public Function Slice(ByVal s, ByVal e) + s = CalculateIndex(s) + e = CalculateIndex(e) + If e < s Then + Set Slice = DynamicArray() + Else + ReDim retval(e - s) + Dim i, j + j = 0 + For i = s to e + Assign retval(j), m_data(i) + j = j + 1 + Next + Set Slice = DynamicArray1(retval) + End If + End Function + + + Public Function Iterator() + Dim retval + Set retval = New Iterator_DynamicArray_Class + retval.Initialize Me + Set Iterator = retval + End Function + + Public Function TO_En() + Set TO_En = En_Iterator(Me.Iterator) + End Function + + Public Function TO_Array() + Dim i + ReDim retval(m_size - 1) + For i = 0 to UBOUND(retval) + Assign retval(i), m_data(i) + Next + TO_Array = retval + End Function + +End Class + + +Public Function DynamicArray() + ReDim data(3) + Set DynamicArray = DynamicArray2(data, 0) +End Function + +Public Function DynamicArray1(ByVal data) + Set DynamicArray1 = DynamicArray2(data, UBOUND(data) + 1) +End Function + +Private Function DynamicArray2(ByVal data, ByVal size) + Dim retval + Set retval = New DynamicArray_Class + retval.Initialize data, size + Set DynamicArray2 = retval +End Function + + +Class Iterator_DynamicArray_Class + Private m_dynamic_array + Private m_index + + Public Sub Initialize(ByVal dynamic_array) + Set m_dynamic_array = dynamic_array + m_index = 0 + End Sub + + Private Sub Class_Terminate + Set m_dynamic_array = Nothing + End Sub + + Public Function HasNext() + HasNext = (m_index < m_dynamic_array.Size) + End Function + + Public Function PeekNext() + Assign PeekNext, m_dynamic_array.FastItem(m_index) + End Function + + Public Function GetNext() + Assign GetNext, m_dynamic_array.FastItem(m_index) + m_index = m_index + 1 + End Function + + Public Function HasPrev() + HasPrev = (m_index > 0) + End Function + + Public Function PeekPrev() + Assign PeekPrev, m_dynamic_array.FastItem(m_index - 1) + End Function + + Public Function GetPrev() + Assign GetPrev, m_dynamic_array.FastItem(m_index - 1) + m_index = m_index - 1 + End Function +End Class + + + +'======================================================================================================================= +' Other Iterators +'======================================================================================================================= +'!!! EXPERIMENTAL !!! May not be very useful, oh well... +Class Iterator_Recordset_Class + Private m_rs + Private m_record_count + Private m_current_index + Private m_field_names 'cached array + + Public Sub Initialize(ByVal rs) + Set m_rs = rs + m_rs.MoveFirst + m_rs.MovePrevious + m_record_count = rs.RecordCount + m_current_index = 0 + + 'cache field names + m_field_names = array() + redim m_field_names(m_rs.Fields.Count) + + dim field + dim i : i = 0 + for each field in m_rs.Fields + m_field_names(i) = field.Name + next + End Sub + + Private Sub Class_Terminate + Set m_rs = Nothing + End Sub + + Public Function HasNext() + HasNext = (m_current_index < m_record_count) + put "m_current_index := " & m_current_index + put "m_record_count := " & m_record_count + End Function + + Public Function PeekNext + if HasNext then + m_rs.MoveNext + Assign PeekNext, GetPairs + m_rs.MovePrevious + else + set PeekNext = Nothing + end if + End Function + + Private Function GetPairs + + End Function + + Public Function GetNext + if m_current_index < m_record_count then + Assign GetNext, m_rs + m_rs.MoveNext + m_current_index = m_current_index + 1 + else + set GetNext = Nothing + end if + End Function + + Public Function HasPrev() + if m_rs.BOF then + HasPrev = false + else + m_rs.MovePrevious + HasPrev = Choice(m_rs.BOF, false, true) + m_rs.MoveNext + end if + End Function + + Public Function PeekPrev + m_rs.MovePrevious + if m_rs.BOF then + set PeekPrev = Nothing + else + Assign PeekPrev, m_rs + end if + m_rs.MoveNext + End Function + + Public Function GetPrev + m_rs.MovePrevious + if m_rs.BOF then + set GetPrev = Nothing + else + Assign GetPrev, m_rs + end if + End Function +End Class + + +Class Iterator_Dictionary_Class + Private m_dic + Private m_keys 'array + Private m_idx 'current array index + Private m_keys_ubound 'cached ubound(m_keys) + + Public Sub Initialize(ByVal dic) + set m_dic = dic + m_keys = m_dic.Keys() + m_idx = -1 + m_keys_ubound = ubound(m_keys) + End Sub + + Private Sub Class_Terminate + set m_dic = Nothing + End Sub + + Public Function HasNext() + HasNext = (m_idx < m_keys_ubound) + End Function + + Public Function PeekNext() + Assign PeekNext, m_dic(m_keys(m_idx + 1)) + End Function + + Public Function GetNext() + Assign GetNext, m_dic(m_keys(m_idx + 1)) + m_idx = m_idx + 1 + End Function + + Public Function HasPrev() + HasPrev = (m_idx > 0) + End Function + + Public Function PeekPrev() + Assign PeekPrev, m_dic(m_keys(m_idx - 1)) + End Function + + Public Function GetPrev() + Assign GetPrev, m_dic(m_keys(m_idx - 1)) + m_idx = m_idx - 1 + End Function +End Class + + +'======================================================================================================================= +' Iterator Factory +'======================================================================================================================= +'Returns the appropriate iterator for the passed-in collection. Errors if unknown collection. +Function IteratorFor(col) + dim result + select case typename(col) + case "LinkedList_Class" : set result = new Iterator_LinkedList_Class + case "Dictionary" : set result = new Iterator_Dictionary_Class + case "Recordset" : set result = new Iterator_Recordset_Class + end select + result.Initialize col + set IteratorFor = result +End Function + + +Class List + Private items + Private P_count + + Private Sub Class_Initialize() + ReDim items(-1) + P_count = 0 + End Sub + + Public Sub Add(value) + ReDim Preserve items(P_count) + If IsObject(value) Then + Set items(P_count) = value + Else + items(P_count) = value + End If + P_count = P_count + 1 + End Sub + + Public Sub AddRange(arrayToAdd) + Dim i + For i = 0 To UBound(arrayToAdd) + Me.Add arrayToAdd(i) + Next + End Sub + + Public Property Get Count() + Count = P_count + End Property + + Public Property Get Item(index) + If index < 0 Or index >= P_count Then + Err.Raise 9, "List", "Index out of bounds" + End If + If IsObject(items(index)) Then + Set Item = items(index) + Else + Item = items(index) + End If + End Property + + Public Property Let Item(index, value) + If index < 0 Or index >= P_count Then + Err.Raise 9, "List", "Index out of bounds" + End If + If IsObject(value) Then + Set items(index) = value + Else + items(index) = value + End If + End Property + + Public Function Contains(ByRef value) + Dim i + For i = 0 To P_count - 1 + If IsObject(items(i)) And IsObject(value) Then + If (items(i) Is value) Then + Contains = True + Exit Function + End If + Else + If items(i) = value Then + Contains = True + Exit Function + End If + End If + Next + Contains = False + End Function + + Public Function IndexOf(value) + Dim i + For i = 0 To P_count - 1 + If IsObject(items(i)) And IsObject(value) Then + If items(i) Is value Then + IndexOf = i + Exit Function + End If + Else + If items(i) = value Then + IndexOf = i + Exit Function + End If + End If + Next + IndexOf = -1 + End Function + + Public Sub Remove(value) + Dim i + i = Me.IndexOf(value) + If i <> -1 Then + Me.RemoveAt i + End If + End Sub + + Public Sub RemoveAt(index) + Dim i + If index < 0 Or index >= P_count Then + Err.Raise 9, "List", "Index out of bounds" + End If + + For i = index To P_count - 2 + If IsObject(items(i + 1)) Then + Set items(i) = items(i + 1) + Else + items(i) = items(i + 1) + End If + Next + + P_count = P_count - 1 + + If P_count <= 0 Then + ReDim items(-1) + Else + ReDim Preserve items(P_count - 1) + End If + End Sub + + Public Sub Clear() + ReDim items(-1) + P_count = 0 + End Sub + + Public Sub Sort() + Dim i, j, tmp + For i = 0 To P_count - 2 + For j = i + 1 To P_count - 1 + If CStr(items(i)) > CStr(items(j)) Then + Set tmp = items(i) + Set items(i) = items(j) + Set items(j) = tmp + End If + Next + Next + End Sub + + ' Note: this will NOT be used automatically by VBScript For Each, + ' but you can use it manually. + Public Function New_Enum() + Set New_Enum = New ListEnumerator + New_Enum.Init items, P_count + End Function +End Class + + +Class ListEnumerator + Private items, index, max + + Public Sub Init(arr, cnt) + items = arr + index = -1 + max = cnt + End Sub + + Public Function MoveNext() + index = index + 1 + MoveNext = (index < max) + End Function + + Public Property Get Current() + Set Current = items(index) + End Property + + Public Sub Reset() + index = -1 + End Sub +End Class + + + +%> + diff --git a/core/lib.ControllerRegistry.asp b/core/lib.ControllerRegistry.asp new file mode 100644 index 0000000..464db8c --- /dev/null +++ b/core/lib.ControllerRegistry.asp @@ -0,0 +1,109 @@ +<% +'======================================================================================================================= +' Controller Registry +' Provides a whitelist of valid controllers to prevent code injection attacks +'======================================================================================================================= + +Class ControllerRegistry_Class + Private m_controllers + + Private Sub Class_Initialize() + Set m_controllers = Server.CreateObject("Scripting.Dictionary") + m_controllers.CompareMode = 1 ' vbTextCompare for case-insensitive + + ' Register all application controllers here. + ' Format: m_controllers.Add "controllername", True + RegisterController "homecontroller" + End Sub + + Private Sub Class_Terminate() + Set m_controllers = Nothing + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Register a controller as valid + '--------------------------------------------------------------------------------------------------------------------- + Public Sub RegisterController(controllerName) + Dim key : key = LCase(Trim(controllerName)) + If Not m_controllers.Exists(key) Then + m_controllers.Add key, True + End If + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Check if a controller is registered (valid) + '--------------------------------------------------------------------------------------------------------------------- + Public Function IsValidController(controllerName) + Dim key : key = LCase(Trim(controllerName)) + IsValidController = m_controllers.Exists(key) + End Function + + '--------------------------------------------------------------------------------------------------------------------- + ' Get list of all registered controllers + '--------------------------------------------------------------------------------------------------------------------- + Public Function GetRegisteredControllers() + GetRegisteredControllers = m_controllers.Keys() + End Function + + '--------------------------------------------------------------------------------------------------------------------- + ' Validate controller name format (alphanumeric and underscore only) + '--------------------------------------------------------------------------------------------------------------------- + Public Function IsValidControllerFormat(controllerName) + If IsEmpty(controllerName) Or Len(controllerName) = 0 Then + IsValidControllerFormat = False + Exit Function + End If + + Dim i, ch + For i = 1 To Len(controllerName) + ch = Mid(controllerName, i, 1) + ' Allow a-z, A-Z, 0-9, and underscore + If Not ((ch >= "a" And ch <= "z") Or _ + (ch >= "A" And ch <= "Z") Or _ + (ch >= "0" And ch <= "9") Or _ + ch = "_") Then + IsValidControllerFormat = False + Exit Function + End If + Next + + IsValidControllerFormat = True + End Function + + '--------------------------------------------------------------------------------------------------------------------- + ' Validate action name format (alphanumeric and underscore only) + '--------------------------------------------------------------------------------------------------------------------- + Public Function IsValidActionFormat(actionName) + If IsEmpty(actionName) Or Len(actionName) = 0 Then + IsValidActionFormat = False + Exit Function + End If + + Dim i, ch + For i = 1 To Len(actionName) + ch = Mid(actionName, i, 1) + ' Allow a-z, A-Z, 0-9, and underscore + If Not ((ch >= "a" And ch <= "z") Or _ + (ch >= "A" And ch <= "Z") Or _ + (ch >= "0" And ch <= "9") Or _ + ch = "_") Then + IsValidActionFormat = False + Exit Function + End If + Next + + IsValidActionFormat = True + End Function + +End Class + +' Singleton instance +Dim ControllerRegistry_Class__Singleton +Function ControllerRegistry() + If IsEmpty(ControllerRegistry_Class__Singleton) Then + Set ControllerRegistry_Class__Singleton = New ControllerRegistry_Class + End If + Set ControllerRegistry = ControllerRegistry_Class__Singleton +End Function + +%> diff --git a/core/lib.DAL.asp b/core/lib.DAL.asp new file mode 100644 index 0000000..b95c0d0 --- /dev/null +++ b/core/lib.DAL.asp @@ -0,0 +1,29 @@ +<% +' This class encapsulates database access into one location, isolating database details from the rest of the app. +' Multiple databases can be handled in one of two ways: +' +' Option 1. Use a single DAL_Class instance with separate public properties for each database. +' Ex: To access Orders use DAL.Orders and to access Employees use DAL.Employees. +' +' Option 2. Use a separate DAL_Class instance for each database. +' Ex: +' dim OrdersDAL : set OrdersDAL = new DAL_Class +' OrdersDAL.ConnectionString = "..." <-- you would have to create this property to use this approach +' +' If you only access one database it is easier to just set the global DAL singleton to an instance of the +' Database_Class and use it directly. See the example project for details. + +'======================================================================================================================= +' DATA ACCESS LAYER Class +'======================================================================================================================= +dim DAL__Singleton : set DAL__Singleton = Nothing + +Function DAL() + If DAL__Singleton is Nothing then + set DAL__Singleton = new Database_Class + DAL__Singleton.Initialize GetAppSetting("ConnectionString") + + End If + set DAL = DAL__Singleton +End Function +%> \ No newline at end of file diff --git a/core/lib.Data.asp b/core/lib.Data.asp new file mode 100644 index 0000000..4750c85 --- /dev/null +++ b/core/lib.Data.asp @@ -0,0 +1,113 @@ +<% +Class Database_Class + Private m_connection + Private m_connection_string + + Private m_trace_enabled + Public Sub set_trace(bool) : m_trace_enabled = bool : End Sub + Public Property Get is_trace_enabled : is_trace_enabled = m_trace_enabled : End Property + + '--------------------------------------------------------------------------------------------------------------------- + Public Sub Initialize(connection_string) + m_connection_string = connection_string + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + Public Function ShapeQuery(sql,params) + dim shapeConn : set shapeConn = server.createobject("adodb.connection") + shapeConn.ConnectionString = "Provider=MSDataShape;Data " & m_connection_string + dim cmd : set cmd = server.createobject("adodb.command") + shapeConn.open + set cmd.ActiveConnection = shapeConn + cmd.CommandText = sql + dim rs + If IsArray(params) then + set rs = cmd.Execute(, params) + ElseIf Not IsEmpty(params) then ' one parameter + set rs = cmd.Execute(, Array(params)) + Else + set rs = cmd.Execute() + End If + set ShapeQuery = rs + End Function + + Public Function Query(sql, params) + dim cmd : set cmd = server.createobject("adodb.command") + set cmd.ActiveConnection = Connection + cmd.CommandText = sql + + dim rs + + If IsArray(params) then + set rs = cmd.Execute(, params) + ElseIf Not IsEmpty(params) then ' one parameter + set rs = cmd.Execute(, Array(params)) + Else + set rs = cmd.Execute() + End If + + set Query = rs + End Function + + '--------------------------------------------------------------------------------------------------------------------- + Public Function PagedQuery(sql, params, per_page, page_num) + dim cmd : set cmd = server.createobject("adodb.command") + set cmd.ActiveConnection = Connection + cmd.CommandText = sql + + cmd.CommandType = 1 'adCmdText + cmd.ActiveConnection.CursorLocation = 3 'adUseClient + + dim rs + + If IsArray(params) then + set rs = cmd.Execute(, params) + ElseIf Not IsEmpty(params) then ' one parameter + set rs = cmd.Execute(, Array(params)) + Else + set rs = cmd.Execute() + End If + + If Not rs.EOF then + rs.PageSize = 1 + rs.CacheSize = 1 + rs.AbsolutePage = 1 + End If + + set PagedQuery = rs + End Function + + '--------------------------------------------------------------------------------------------------------------------- + Public Sub [Execute](sql, params) + me.query sql, params + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + Public Sub BeginTransaction + Connection.BeginTrans + End Sub + + Public Sub RollbackTransaction + Connection.RollbackTrans + End Sub + + Public Sub CommitTransaction + Connection.CommitTrans + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Private Methods + '--------------------------------------------------------------------------------------------------------------------- + Private Sub Class_terminate + Destroy m_connection + End Sub + + Public Function Connection + if not isobject(m_connection) then + set m_connection = Server.CreateObject("adodb.connection") + m_connection.open m_connection_string + end if + set Connection = m_connection + End Function +end Class +%> \ No newline at end of file diff --git a/core/lib.Enumerable.asp b/core/lib.Enumerable.asp new file mode 100644 index 0000000..00768d9 --- /dev/null +++ b/core/lib.Enumerable.asp @@ -0,0 +1,202 @@ +<% +Class EnumerableHelper_Class + Private m_list + + Public Sub Init(list) + set m_list = list + End Sub + + Public Sub Class_Terminate + set m_list = Nothing + End Sub + + Public Default Function Data() + set Data = m_list + End Function + + + '--------------------------------------------------------------------------------------------------------------------- + ' Convenience wrappers + '--------------------------------------------------------------------------------------------------------------------- + + Public Function Count() + Count = m_list.Count() + End Function + + Public Function First() + Assign First, m_list.Front() + End Function + + Public Function Last() + Assign Last, m_list.Back() + End Function + + '--------------------------------------------------------------------------------------------------------------------- + ' Methods that return a single value + '--------------------------------------------------------------------------------------------------------------------- + + 'true if all elements of the list satisfy the condition + Public Function All(condition) + dim item_, all_matched : all_matched = true + dim it : set it = m_list.Iterator + Do While it.HasNext + Assign item_, it.GetNext() + If "String" = typename(condition) then + If Not eval(condition) then + all_matched = false + End If + Else + If Not condition(item_) then + all_matched = false + End If + End If + If Not all_matched then Exit Do + Loop + All = all_matched + End Function + + 'true if any element of the list satisfies the condition + Public Function Any(condition) + Any = Not All("Not " & condition) + End Function + + Public Function Max(expr) + dim V_, item_, maxval + dim it : set it = m_list.Iterator + If "String" = typename(expr) then + While it.HasNext + Assign item_, it.GetNext() + Assign V_, eval(expr) + If V_ > maxval then maxval = V_ + Wend + Else + While it.HasNext + Assign item_, it.GetNext() + Assign V_, expr(item_) + If V_ > maxval then maxval = V_ + Wend + End If + Max = maxval + End Function + + Public Function Min(expr) + dim V_, item_, minval + dim it : set it = m_list.Iterator + If "String" = typename(expr) then + While it.HasNext + Assign item_, it.GetNext() + If IsEmpty(minval) then ' empty is always less than everything so set it on first pass + Assign minval, item_ + End If + Assign V_, eval(expr) + If V_ < minval then minval = V_ + Wend + Else + While it.HasNext + Assign item_, it.GetNext() + If IsEmpty(minval) then + Assign minval, item_ + End If + V_ = expr(item_) + If V_ < minval then minval = V_ + Wend + End If + Min = minval + End Function + + Public Function Sum(expr) + dim V_, item_ + dim it : set it = m_list.Iterator + While it.HasNext + Assign item_, it.GetNext() + execute "V_ = V_ + " & expr + Wend + Sum = V_ + End Function + + + '--------------------------------------------------------------------------------------------------------------------- + ' Methods that return a new instance of this class + '--------------------------------------------------------------------------------------------------------------------- + + 'returns a list that results from running lambda_or_proc once for every element in the list + Public Function Map(lambda_or_proc) + dim list2 : set list2 = new LinkedList_Class + dim it : set it = m_list.Iterator + dim item_ + If "String" = typename(lambda_or_proc) then + dim V_ + While it.HasNext + Assign item_, it.GetNext() + execute lambda_or_proc + list2.Push V_ + Wend + Else + While it.HasNext + Assign item_, it.GetNext() + list2.Push lambda_or_proc(item_) + Wend + End If + set Map = Enumerable(list2) + End Function + + 'alias to match IEnumerable for convenience + Public Function [Select](lambda_or_proc) + set [Select] = Map(lambda_or_proc) + End Function + + 'returns list containing first n items + Public Function Take(n) + dim list2 : set list2 = new LinkedList_Class + dim it : set it = m_list.Iterator + dim i : i = 1 + While it.HasNext And i <= n + list2.Push it.GetNext() + i = i + 1 + Wend + set Take = Enumerable(list2) + End Function + + 'returns list containing elements as long as the condition is true, and skips the remaining elements + Public Function TakeWhile(condition) + dim list2 : set list2 = new LinkedList_Class + dim item_, V_, bln + dim it : set it = m_list.Iterator + Do While it.HasNext + Assign item_, it.GetNext() + If "String" = typename(condition) then + 'execute condition + If Not eval(condition) then Exit Do + Else + If Not condition(item_) then Exit Do + End If + list2.Push item_ + Loop + set TakeWhile = Enumerable(list2) + End Function + + 'returns a list containing only elements that satisfy the condition + Public Function Where(condition) + dim list2 : set list2 = new LinkedList_Class + dim it : set it = m_list.Iterator + dim item_ + While it.HasNext + Assign item_, it.GetNext() + If "String" = typename(condition) then + If eval(condition) then list2.Push item_ + Else + If condition(item_) then list2.Push item_ + End If + Wend + set Where = Enumerable(list2) + End Function + +End Class + + +Function Enumerable(list) + dim E : set E = new EnumerableHelper_Class + E.Init list + set Enumerable = E +End Function +%> \ No newline at end of file diff --git a/core/lib.ErrorHandler.asp b/core/lib.ErrorHandler.asp new file mode 100644 index 0000000..c15ccb7 --- /dev/null +++ b/core/lib.ErrorHandler.asp @@ -0,0 +1,178 @@ +<% +'======================================================================================================================= +' Error Handler Library +' Provides centralized error handling and logging functionality +'======================================================================================================================= + +Class ErrorHandler_Class + Private m_log_to_file + Private m_log_file_path + + Private Sub Class_Initialize() + m_log_to_file = False + m_log_file_path = "" + End Sub + + ' Configure whether to log errors to file + Public Property Let LogToFile(value) + m_log_to_file = value + End Property + + Public Property Get LogToFile() + LogToFile = m_log_to_file + End Property + + ' Set the log file path + Public Property Let LogFilePath(value) + m_log_file_path = value + End Property + + Public Property Get LogFilePath() + LogFilePath = m_log_file_path + End Property + + '--------------------------------------------------------------------------------------------------------------------- + ' Main error handling method + ' context: String describing where the error occurred + ' errObj: VBScript Err object (optional, uses global Err if not provided) + '--------------------------------------------------------------------------------------------------------------------- + Public Sub HandleError(context, errObj) + Dim isDevelopment + isDevelopment = (LCase(GetAppSetting("Environment")) = "development") + + If IsEmpty(errObj) Or Not IsObject(errObj) Then + ' Use global Err object if none provided + If Err.Number <> 0 Then + If isDevelopment Then + ShowDetailedError context, Err + Else + ShowGenericError + End If + LogError context, Err + End If + Else + If errObj.Number <> 0 Then + If isDevelopment Then + ShowDetailedError context, errObj + Else + ShowGenericError + End If + LogError context, errObj + End If + End If + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Display detailed error information (Development mode only) + '--------------------------------------------------------------------------------------------------------------------- + Private Sub ShowDetailedError(context, errObj) + Dim errHtml + errHtml = "
" + errHtml = errHtml & "Error Occurred
" + + If Not IsEmpty(context) And Len(context) > 0 Then + errHtml = errHtml & "Context: " & Server.HTMLEncode(context) & "
" + End If + + errHtml = errHtml & "Time: " & Now() & "
" + errHtml = errHtml & "Number: " & errObj.Number & "
" + errHtml = errHtml & "Description: " & Server.HTMLEncode(errObj.Description) & "
" + + If Len(errObj.Source) > 0 Then + errHtml = errHtml & "Source: " & Server.HTMLEncode(errObj.Source) & "
" + End If + + errHtml = errHtml & "
" + Response.Write errHtml + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Display generic error message (Production mode) + '--------------------------------------------------------------------------------------------------------------------- + Private Sub ShowGenericError() + Dim errHtml + errHtml = "
" + errHtml = errHtml & "An error occurred
" + errHtml = errHtml & "We apologize for the inconvenience. The error has been logged and will be investigated.
" + errHtml = errHtml & "Please try again later or contact support if the problem persists." + errHtml = errHtml & "
" + Response.Write errHtml + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Log error to file (if enabled) + '--------------------------------------------------------------------------------------------------------------------- + Private Sub LogError(context, errObj) + If Not m_log_to_file Or Len(m_log_file_path) = 0 Then Exit Sub + + On Error Resume Next + Dim fso, logFile, logEntry + + Set fso = Server.CreateObject("Scripting.FileSystemObject") + + ' Create log entry + logEntry = "[" & Now() & "] " + If Len(context) > 0 Then + logEntry = logEntry & "Context: " & context & " | " + End If + logEntry = logEntry & "Error #" & errObj.Number & ": " & errObj.Description + + If Len(errObj.Source) > 0 Then + logEntry = logEntry & " | Source: " & errObj.Source + End If + + logEntry = logEntry & vbCrLf + + ' Append to log file + If fso.FileExists(m_log_file_path) Then + Set logFile = fso.OpenTextFile(m_log_file_path, 8, False) ' 8 = ForAppending + Else + Set logFile = fso.CreateTextFile(m_log_file_path, True) + End If + + logFile.Write logEntry + logFile.Close + Set logFile = Nothing + Set fso = Nothing + + On Error GoTo 0 + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Quick check if an error exists + '--------------------------------------------------------------------------------------------------------------------- + Public Function HasError() + HasError = (Err.Number <> 0) + End Function + + '--------------------------------------------------------------------------------------------------------------------- + ' Clear the current error + '--------------------------------------------------------------------------------------------------------------------- + Public Sub ClearError() + Err.Clear + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Check and handle error in one call + '--------------------------------------------------------------------------------------------------------------------- + Public Function CheckAndHandle(context) + If Err.Number <> 0 Then + HandleError context, Err + CheckAndHandle = True + Else + CheckAndHandle = False + End If + End Function + +End Class + +' Singleton instance +Dim ErrorHandler_Class__Singleton +Function ErrorHandler() + If IsEmpty(ErrorHandler_Class__Singleton) Then + Set ErrorHandler_Class__Singleton = New ErrorHandler_Class + End If + Set ErrorHandler = ErrorHandler_Class__Singleton +End Function + +%> diff --git a/core/lib.Flash.asp b/core/lib.Flash.asp new file mode 100644 index 0000000..fbd1968 --- /dev/null +++ b/core/lib.Flash.asp @@ -0,0 +1,151 @@ +<% +'======================================================================================================================= +' Flash Message Class +'======================================================================================================================= +Class Flash_Class + Private m_errors_key + Private m_success_key + + Private Sub Class_Initialize + ' Use constants to avoid typos + m_errors_key = "mvc.flash.errors_array" + m_success_key = "mvc.flash.success_message" + End Sub + + 'helper methods to avoid if..then statements in views + Public Sub ShowErrorsIfPresent + if HasErrors then ShowErrors + End Sub + + Public Sub ShowSuccessIfPresent + if HasSuccess then ShowSuccess + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Errors + '--------------------------------------------------------------------------------------------------------------------- + Public Property Get HasErrors + HasErrors = (Not IsEmpty(Session(m_errors_key))) + End Property + + Public Property Get Errors + Errors = Session(m_errors_key) + End Property + + Public Property Let Errors(ary) + Session(m_errors_key) = ary + End Property + + Public Sub AddError(msg) + dim ary + if IsEmpty(Session(m_errors_key)) then + ary = Array() + redim ary(-1) + else + ary = Session(m_errors_key) + end if + redim preserve ary(ubound(ary) + 1) + ary(ubound(ary)) = msg + Session(m_errors_key) = ary + End Sub + + 'Public Sub ShowErrors + ' ClearErrors + 'End Sub + + Public Sub ShowErrors + if HasErrors then + %> + + + <% + ClearErrors + end if + End Sub + + Public Sub ClearErrors + Session.Contents.Remove(m_errors_key) + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Success + '--------------------------------------------------------------------------------------------------------------------- + Public Property Get HasSuccess + HasSuccess = (Not IsEmpty(Session(m_success_key))) + End Property + + Public Property Get Success + Success = Session(m_success_key) + End Property + + Public Property Let Success(msg) + Session(m_success_key) = msg + End Property + + Public Sub ShowSuccess + if HasSuccess then + %> + + + <% + ClearSuccess + end if + End Sub + + Public Sub ClearSuccess + Session.Contents.Remove(m_success_key) + End Sub + +End Class + +Function Flash() + set Flash = new Flash_Class +End Function +%> diff --git a/core/lib.FormCache.asp b/core/lib.FormCache.asp new file mode 100644 index 0000000..62ce1a5 --- /dev/null +++ b/core/lib.FormCache.asp @@ -0,0 +1,79 @@ +<% +Class FormCache_Class + 'given a form name and IRequestDictionary params (request.form) object, caches form values + Public Sub SerializeForm(form_name, params) + dim form_key, form_val, serialized_key + For Each form_key in params + form_val = params(form_key) + serialized_key = CachedFormKeyName(form_name, form_key) + 'put "serialize
" + 'put "--form_key := " & form_key & "
" + 'put "--form_val := " & form_val & "
" + 'put "--serialized_key := " & serialized_key & "
" + Session(serialized_key) = form_val + Next + End Sub + + 'given a form name, returns a dict with the form's stored values + Public Function DeserializeForm(form_name) + dim dict : set dict = Nothing + dim serialized_key, serialized_val, form_key, form_val + + For Each serialized_key in Session.Contents + 'put "serialized_key: " & serialized_key & "
" + If InStr(serialized_key, "mvc.form." & form_name) > 0 then + 'put "--match" & "
" + + If dict Is Nothing then + set dict = Server.CreateObject("Scripting.Dictionary") + 'put "dict created
" + End If + + form_val = Session(serialized_key) + form_key = Replace(serialized_key, "mvc.form." & form_name & ".", "") + dict(form_key) = form_val + 'Session.Contents.Remove serialized_key + + 'put "--serialized_val: " & serialized_val & "
" + 'put "--form_val: " & form_val & "
" + End If + Next + set DeserializeForm = dict + End Function + + 'given a form name, clears the keys for that form + Public Sub ClearForm(form_name) + Dim key, prefix, keysToRemove(), idx + + prefix = "mvc.form." & form_name & "." + ReDim keysToRemove(-1) + + ' First collect the keys to remove + For Each key In Session.Contents + If Left(CStr(key), Len(prefix)) = prefix Then + ReDim Preserve keysToRemove(UBound(keysToRemove) + 1) + keysToRemove(UBound(keysToRemove)) = key + End If + Next + + ' Then remove them + For idx = 0 To UBound(keysToRemove) + Session.Contents.Remove keysToRemove(idx) + Next + End Sub + + + Private Function CachedFormKeyName(form_name, key) + CachedFormKeyName = "mvc.form." & form_name & "." & key + End Function +End Class + + +dim FormCache__Singleton +Function FormCache() + if IsEmpty(FormCache__Singleton) then + set FormCache__Singleton = new FormCache_Class + end if + set FormCache = FormCache__Singleton +End Function +%> \ No newline at end of file diff --git a/core/lib.HTML.Security.asp b/core/lib.HTML.Security.asp new file mode 100644 index 0000000..871ae90 --- /dev/null +++ b/core/lib.HTML.Security.asp @@ -0,0 +1,77 @@ +<% +'======================================================================================================================= +' HTML SECURITY HELPER +'======================================================================================================================= +Class HTML_Security_Helper_Class + + '--------------------------------------------------------------------------------------------------------------------- + 'Uses Scriptlet.TypeLib to generate a GUID. There may be a better/faster way than this to generate a nonce. + Public Function Nonce() + dim TL : set TL = CreateObject("Scriptlet.TypeLib") + Nonce = Left(CStr(TL.Guid), 38) 'avoids issue w/ strings appended after this token not being displayed on screen, MSFT bug + set TL = Nothing + End Function + + '--------------------------------------------------------------------------------------------------------------------- + 'Name is probably the combined ControllerName and ActionName of the form generator by convention + Public Sub SetAntiCSRFToken(name) + Session(name & ".anti_csrf_token") = Nonce() + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + 'Returns the CSRF token nonce from the session corresponding to the passed name + Public Function GetAntiCSRFToken(name) + dim token : token = Session(name & ".anti_csrf_token") + If Len(token) = 0 or IsEmpty(token) then + SetAntiCSRFToken name + End If + GetAntiCSRFToken = token + End Function + + '--------------------------------------------------------------------------------------------------------------------- + 'Removes the current CSRF token nonce for the passed name + Public Sub ClearAntiCSRFToken(name) + Session.Contents.Remove(name & ".anti_csrf_token") + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + 'Returns true if passed nonce matches the stored CSRF token nonce for the specified name, false if not + Public Function IsValidAntiCSRFToken(name, nonce) + IsValidAntiCSRFToken = (GetAntiCSRFToken(name) = nonce) + End Function + + '--------------------------------------------------------------------------------------------------------------------- + 'If an invalid CSRF nonce is passed, sets the flash and redirects using the appropriate MVC.Redirect* method. + 'If a valid CSRF nonce is passed, clears it from the cache to reset the state to the beginning. + Public Sub OnInvalidAntiCSRFTokenRedirectToAction(token_name, token, action_name) + OnInvalidAntiCSRFTokenRedirectToExt token_name, token, MVC.ControllerName, action_name, empty + End Sub + + Public Sub OnInvalidAntiCSRFTokenRedirectToActionExt(token_name, token, action_name, params) + OnInvalidAntiCSRFTokenRedirectToExt token_name, token, MVC.ControllerName, action_name, params + End Sub + + Public Sub OnInvalidAntiCSRFTokenRedirectTo(token_name, token, controller_name, action_name) + OnInvalidAntiCSRFTokenRedirectToExt token_name, token, controller_name, action_name + End Sub + + Public Sub OnInvalidAntiCSRFTokenRedirectToExt(token_name, token, controller_name, action_name, params) + If IsValidAntiCSRFToken(token_name, token) then + ClearAntiCSRFToken token_name + Else + ClearAntiCSRFToken token_name + Flash.AddError "Invalid form state. Please try again." + MVC.RedirectToExt controller_name, action_name, params + End If + End Sub +End Class + + +dim HTML_Security_Helper__Singleton +Function HTMLSecurity() + If IsEmpty(HTML_Security_Helper__Singleton) Then + set HTML_Security_Helper__Singleton = new HTML_Security_Helper_Class + End If + set HTMLSecurity = HTML_Security_Helper__Singleton +End Function +%> diff --git a/core/lib.HTML.asp b/core/lib.HTML.asp new file mode 100644 index 0000000..a993f23 --- /dev/null +++ b/core/lib.HTML.asp @@ -0,0 +1,282 @@ +<% +'======================================================================================================================= +' HTML HELPER +'======================================================================================================================= +Class HTML_Helper_Class + 'Duplicate of Routes.NoCacheToken, copied to avoid extra lookup into the Routes object for such a trivial function. + 'Allows caller to reference HTML.NoCacheToken in cases where it seems to feel right. + Public Property Get NoCacheToken + NoCacheToken = Timer() * 100 + End Property + + 'Ensures safe output + Public Function Encode(ByVal value) + If Not IsEmpty(value) and Not IsNull(value) then + Encode = Server.HtmlEncode(value) + End If + End Function + + '--------------------------------------------------------------------------------------------------------------------- + 'LinkTo and its relatives DO NOT HTMLEncode the link_text! This allows use of HTML within the link, especially + 'useful for Bootstrap icons and the like. + ' + 'Bottom Line: If you need to HTMLEncode the link text YOU MUST DO IT YOURSELF! The H() method makes this easy! + Public Function LinkTo(link_text, controller_name, action_name) + LinkTo = LinkToExt(link_text, controller_name, action_name, empty, empty) + End Function + + Public Function LinkToExt(link_text, controller_name, action_name, params_array, attribs_array) + LinkToExt = "" & link_text & "" & vbCR + End Function + + Public Function LinkToIf(condition, link_text, controller_name, action_name) + if condition then + LinkToIf = LinkToExt(link_text, controller_name, action_name, empty, empty) + end if + End Function + + Public Function LinkToExtIf(condition, link_text, controller_name, action_name, params_array, attribs_array) + if condition then + LinkToExtIf = LinkToExt(link_text, controller_name, action_name, params_array, attribs_array) + end if + End Function + + Public Function LinkToUnless(condition, link_text, controller_name, action_name) + if not condition then + LinkToIf = LinkToExt(link_text, controller_name, action_name, empty, empty) + end if + End Function + + Public Function LinkToExtUnless(condition, link_text, controller_name, action_name, params_array, attribs_array) + if not condition then + LinkToExtUnless = LinkToExt(link_text, controller_name, action_name, params_array, attribs_array) + end if + End Function + + + '' + ' Creates a form button and a hidden form to enforce POST submissions. Params are in hidden fields. + '' + 'Public Function PostButtonLinkTo(controller_name, action_name, params) + ' dim id : id = "post_button__" & controller_name & action_name + ' dim s + ' s = "
" + ' dim i, key, val + ' for i = 0 to ubound(params) step 2 + ' KeyVal params, i, key, val + ' s = s & "" + ' next + ' s = s & "" + ' s = s & "
" + ' PostButtonLinkTo = s + 'End Function + + Public Function PostButtonTo(button_contents, controller_name, action_name, form_fields) + PostButtonTo = PostButtonToExt(button_contents, controller_name, action_name, form_fields, empty) + End Function + + Public Function PostButtonToExt(button_contents, controller_name, action_name, form_fields, url_params) + dim s : s = "
" + dim i, key, val + for i = 0 to ubound(form_fields) step 2 + KeyVal form_fields, i, key, val + s = s & HTML.Hidden(key, val) + next + s = s & HTML.SubmitButton(button_contents) + s = s & "
" & vbCR + PostButtonToExt = s + End Function + + Public Function AppStylesheetTag + AppStylesheetTag = StylesheetTag(Routes.StylesheetsURL & "App.css") + End Function + + Public Function ControllerStylesheetTag + ControllerStylesheetTag = StylesheetTag(Routes.StylesheetsUrl & MVC.ControllerName & "Controller.css") + End Function + + Public Function StylesheetTag(url) + StylesheetTag = "" & vbCR + End Function + + Public Function JSTag(url) + JSTag = "" & vbCR + End Function + + '--------------------------------------------------------------------------------------------------------------------- + ' Form Helpers + '--------------------------------------------------------------------------------------------------------------------- + Public Function FormTag(controller_name, action_name, route_attribs, form_attribs) + FormTag = "
" & vbCR + End Function + + Public Function Label(name, for_name) + Label = LabelExt(name, for_name, empty) + End Function + + Public Function LabelExt(name, for_name, attribs) + LabelExt = "" & vbCR + End Function + + Public Function Hidden(id, value) + Hidden = HiddenExt(id, value, empty) + End Function + + Public Function HiddenExt(id, value, attribs) + HiddenExt = "" & vbCR + End Function + + Public Function TextBox(id, value) + TextBox = TextBoxExt(id, value, empty) + End Function + + Public Function TextBoxExt(id, value, attribs) + TextBoxExt = "" & vbCR + End Function + + Public Function TextArea(id, value, rows, cols) + TextArea = TextAreaExt(id, value, rows, cols, empty) + End Function + + Public Function TextAreaExt(id, value, rows, cols, attribs) + TextAreaExt = "" & vbCR + End Function + + '--------------------------------------------------------------------------------------------------------------------- + 'If list is a recordset then option_value_field and option_text_field are required. + 'If list is an array the method assumes it is a KVArray and those parameters are ignored. + Public Function DropDownList(id, selected_value, list, option_value_field, option_text_field) + DropDownList = DropDownListExt(id, selected_value, list, option_value_field, option_text_field, empty) + End Function + + Public Function DropDownListExt(id, selected_value, list, option_value_field, option_text_field, attribs) + If IsNull(selected_value) then + selected_value = "" + Else + selected_value = CStr(selected_value) + End If + + dim item, options, opt_val, opt_txt + options = "" & vbCR + End If + + list.MoveNext + loop + case "Variant()" 'assumes KVArray + dim i + for i = 0 to ubound(list) step 2 + KeyVal list, i, opt_val, opt_txt + options = options & "" & vbCR + next + end select + DropDownListExt = "" & vbCR + End Function + + Public Function Checkbox(id, value) + Checkbox = CheckboxExt(id, value, empty) + End Function + + Public Function CheckboxExt(id, value, attribs) + CheckBoxExt = "" & vbCR + End Function + + '--------------------------------------------------------------------------------------------------------------------- + 'Button text IS NOT ENCODED! As with LinkTo, this allows use of Bootstrap icons and other arbitrary HTML in the + 'button. If you need to HTMLEncode the text you MUST do it yourself! + Public Function SubmitButton(text) + SubmitButton = "" & vbCR + End Function + + Public Function Button(button_type, text, class_name) + Button = "" & vbCR + End Function + + Public Function ButtonExt(button_type, text, attribs_array) + ButtonExt = "" & vbCR + End Function + + + + '--------------------------------------------------------------------------------------------------------------------- + Public Function Tag(Tag_name, attribs_array) + Tag = "<" & Encode(tag_name) & " " & HtmlAttribs(attribs_array) & ">" + End Function + + Public Function Tag_(Tag_name) + Tag_ = "" + End Function + + + '--------------------------------------------------------------------------------------------------------------------- + Public Function HtmlAttribs(attribs) + dim result : result = "" + if not IsEmpty(attribs) then + if IsArray(attribs) then + dim idx + for idx = lbound(attribs) to ubound(attribs) step 2 + result = result & " " & HtmlAttrib(attribs, idx) & " " + next + else ' assume string or string-like default value + result = attribs + end if + end if + HtmlAttribs = result + End Function + + Public Function HtmlAttrib(attribs_array, key_idx) + dim key, val + KeyVal attribs_array, key_idx, key, val + HtmlAttrib = Encode(key) & "='" & Encode(val) & "'" + End Function + + Function checkboxfor(fieldName, isChecked) + Dim idSuffix, checkboxId, html + + ' Decide on the id suffix and checked attribute + If isChecked Then + idSuffix = "Checked" + Else + idSuffix = "Default" + End If + + checkboxId = "flexSwitchCheck" & idSuffix + + ' Build the HTML string + html = "
" & vbCrLf + html = html & " " & vbCrLf + html = html & " " & vbCrLf + html = html & "
" + + checkboxfor = html +End Function + + +End Class + + +dim HTML_Helper__Singleton : set HTML_Helper__Singleton = Nothing +Function HTML() + if HTML_Helper__Singleton Is Nothing then + set HTML_Helper__Singleton = new HTML_Helper_Class + End if + set HTML = HTML_Helper__Singleton +End Function + + +%> diff --git a/core/lib.Migrations.asp b/core/lib.Migrations.asp new file mode 100644 index 0000000..8f92694 --- /dev/null +++ b/core/lib.Migrations.asp @@ -0,0 +1,439 @@ +<% +'======================================================================================================================= +' MIGRATION SYSTEM +'======================================================================================================================= +' Provides database migration capabilities for version-controlled schema changes. +' +' Features: +' - Sequential migration versioning (timestamp-based) +' - Up/Down migration support +' - Migration tracking in schema_migrations table +' - Transaction support for atomic migrations +' - Migration status checking +' +' Usage: +' Set migrator = Migrator() +' migrator.ApplyMigration "20260109120000_create_users_table.asp" +' migrator.RollbackMigration "20260109120000_create_users_table.asp" +' pending = migrator.GetPendingMigrations() +' applied = migrator.GetAppliedMigrations() +' + +Class Migrator_Class + Private m_db + Private m_migrations_path + Private m_schema_table + + '------------------------------------------------------------------------------------------------------------------- + Private Sub Class_Initialize() + Set m_db = DAL() + m_schema_table = "schema_migrations" + m_migrations_path = Server.MapPath("../db/migrations/") + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Ensure the schema_migrations table exists + '------------------------------------------------------------------------------------------------------------------- + Public Sub EnsureSchemaMigrationsTable() + On Error Resume Next + + ' Try to query the table - if it doesn't exist, create it + Dim rs + Set rs = m_db.Query("SELECT TOP 1 version FROM " & m_schema_table, empty) + + If Err.Number <> 0 Then + ' Table doesn't exist, create it + Err.Clear + On Error GoTo 0 + + Dim createSQL + createSQL = "CREATE TABLE " & m_schema_table & " (" & _ + "version VARCHAR(14) PRIMARY KEY, " & _ + "applied_at DATETIME NOT NULL)" + + m_db.Execute createSQL, empty + Else + If Not rs Is Nothing Then + rs.Close + Set rs = Nothing + End If + End If + + On Error GoTo 0 + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Get all applied migration versions + '------------------------------------------------------------------------------------------------------------------- + Public Function GetAppliedMigrations() + EnsureSchemaMigrationsTable + + Dim rs, versions, version + Set versions = Server.CreateObject("Scripting.Dictionary") + + Set rs = m_db.Query("SELECT version FROM " & m_schema_table & " ORDER BY version", empty) + + Do While Not rs.EOF + version = Trim(rs("version")) + versions.Add version, True + rs.MoveNext + Loop + + rs.Close + Set rs = Nothing + + Set GetAppliedMigrations = versions + End Function + + '------------------------------------------------------------------------------------------------------------------- + ' Get all available migration files + '------------------------------------------------------------------------------------------------------------------- + Public Function GetAvailableMigrations() + Dim fso, folder, files, file + Set fso = Server.CreateObject("Scripting.FileSystemObject") + + If Not fso.FolderExists(m_migrations_path) Then + Set GetAvailableMigrations = Server.CreateObject("Scripting.Dictionary") + Exit Function + End If + + Set folder = fso.GetFolder(m_migrations_path) + Set files = folder.Files + + Dim migrations + Set migrations = Server.CreateObject("Scripting.Dictionary") + + For Each file In files + If LCase(fso.GetExtensionName(file.Name)) = "asp" Then + Dim version + version = GetVersionFromFilename(file.Name) + If version <> "" Then + migrations.Add version, file.Name + End If + End If + Next + + Set GetAvailableMigrations = migrations + End Function + + '------------------------------------------------------------------------------------------------------------------- + ' Get pending migrations (available but not applied) + '------------------------------------------------------------------------------------------------------------------- + Public Function GetPendingMigrations() + Dim applied, available, pending, version + Set applied = GetAppliedMigrations() + Set available = GetAvailableMigrations() + Set pending = Server.CreateObject("Scripting.Dictionary") + + For Each version In available.Keys + If Not applied.Exists(version) Then + pending.Add version, available(version) + End If + Next + + Set GetPendingMigrations = pending + End Function + + '------------------------------------------------------------------------------------------------------------------- + ' Extract version from migration filename + ' Expected format: YYYYMMDDHHMMSS_description.asp + '------------------------------------------------------------------------------------------------------------------- + Private Function GetVersionFromFilename(filename) + Dim parts + parts = Split(filename, "_") + + If UBound(parts) >= 0 Then + Dim version + version = parts(0) + ' Validate it's a 14-digit timestamp + If Len(version) = 14 And IsNumeric(version) Then + GetVersionFromFilename = version + Exit Function + End If + End If + + GetVersionFromFilename = "" + End Function + + '------------------------------------------------------------------------------------------------------------------- + ' Apply a migration (run the Up method) + '------------------------------------------------------------------------------------------------------------------- + Public Sub ApplyMigration(filename) + Dim version + version = GetVersionFromFilename(filename) + + If version = "" Then + Err.Raise vbObjectError + 1, "Migrator", "Invalid migration filename format: " & filename + End If + + ' Check if already applied + Dim applied + Set applied = GetAppliedMigrations() + If applied.Exists(version) Then + Response.Write "Migration " & version & " already applied. Skipping." & vbCrLf + Exit Sub + End If + + Response.Write "Applying migration: " & filename & "..." & vbCrLf + + ' Begin transaction + m_db.BeginTransaction + + On Error Resume Next + + ' Execute the migration file + ExecuteMigrationFile filename, "Up" + + If Err.Number <> 0 Then + Dim errMsg + errMsg = "Migration failed: " & Err.Description + m_db.RollbackTransaction + Err.Raise vbObjectError + 2, "Migrator", errMsg + End If + + ' Record the migration + m_db.Execute "INSERT INTO " & m_schema_table & " (version, applied_at) VALUES (?, ?)", _ + Array(version, Now()) + + If Err.Number <> 0 Then + Dim recordErr + recordErr = "Failed to record migration: " & Err.Description + m_db.RollbackTransaction + Err.Raise vbObjectError + 3, "Migrator", recordErr + End If + + ' Commit transaction + m_db.CommitTransaction + + On Error GoTo 0 + + Response.Write "Migration " & version & " applied successfully." & vbCrLf + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Rollback a migration (run the Down method) + '------------------------------------------------------------------------------------------------------------------- + Public Sub RollbackMigration(filename) + Dim version + version = GetVersionFromFilename(filename) + + If version = "" Then + Err.Raise vbObjectError + 1, "Migrator", "Invalid migration filename format: " & filename + End If + + ' Check if applied + Dim applied + Set applied = GetAppliedMigrations() + If Not applied.Exists(version) Then + Response.Write "Migration " & version & " not applied. Skipping." & vbCrLf + Exit Sub + End If + + Response.Write "Rolling back migration: " & filename & "..." & vbCrLf + + ' Begin transaction + m_db.BeginTransaction + + On Error Resume Next + + ' Execute the migration file + ExecuteMigrationFile filename, "Down" + + If Err.Number <> 0 Then + Dim errMsg + errMsg = "Rollback failed: " & Err.Description + m_db.RollbackTransaction + Err.Raise vbObjectError + 4, "Migrator", errMsg + End If + + ' Remove the migration record + m_db.Execute "DELETE FROM " & m_schema_table & " WHERE version = ?", version + + If Err.Number <> 0 Then + Dim recordErr + recordErr = "Failed to remove migration record: " & Err.Description + m_db.RollbackTransaction + Err.Raise vbObjectError + 5, "Migrator", recordErr + End If + + ' Commit transaction + m_db.CommitTransaction + + On Error GoTo 0 + + Response.Write "Migration " & version & " rolled back successfully." & vbCrLf + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Execute a migration file's Up or Down method + '------------------------------------------------------------------------------------------------------------------- + Private Sub ExecuteMigrationFile(filename, direction) + Dim migrationPath + migrationPath = m_migrations_path & filename + + Dim fso + Set fso = Server.CreateObject("Scripting.FileSystemObject") + + If Not fso.FileExists(migrationPath) Then + Err.Raise vbObjectError + 6, "Migrator", "Migration file not found: " & migrationPath + End If + + ' Create a migration context that the file can use + Dim migration + Set migration = New MigrationContext_Class + Set migration.DB = m_db + + ' Include and execute the migration file + Server.Execute(migrationPath) + + ' Call the appropriate method (Up or Down) + If direction = "Up" Then + Execute "Call Migration_Up(migration)" + ElseIf direction = "Down" Then + Execute "Call Migration_Down(migration)" + End If + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Apply all pending migrations + '------------------------------------------------------------------------------------------------------------------- + Public Sub ApplyAllPending() + Dim pending, version, versions() + Set pending = GetPendingMigrations() + + If pending.Count = 0 Then + Response.Write "No pending migrations." & vbCrLf + Exit Sub + End If + + ' Sort versions + ReDim versions(pending.Count - 1) + Dim i : i = 0 + For Each version In pending.Keys + versions(i) = version + i = i + 1 + Next + + ' Simple bubble sort for versions + Dim j, temp + For i = 0 To UBound(versions) - 1 + For j = i + 1 To UBound(versions) + If CLng(versions(i)) > CLng(versions(j)) Then + temp = versions(i) + versions(i) = versions(j) + versions(j) = temp + End If + Next + Next + + ' Apply in order + For i = 0 To UBound(versions) + ApplyMigration pending(versions(i)) + Next + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Rollback the last applied migration + '------------------------------------------------------------------------------------------------------------------- + Public Sub RollbackLast() + Dim applied, version, lastVersion + Set applied = GetAppliedMigrations() + + If applied.Count = 0 Then + Response.Write "No migrations to rollback." & vbCrLf + Exit Sub + End If + + ' Find the last version + lastVersion = "" + For Each version In applied.Keys + If lastVersion = "" Or CLng(version) > CLng(lastVersion) Then + lastVersion = version + End If + Next + + ' Find the filename + Dim available + Set available = GetAvailableMigrations() + + If available.Exists(lastVersion) Then + RollbackMigration available(lastVersion) + Else + Err.Raise vbObjectError + 7, "Migrator", "Migration file not found for version: " & lastVersion + End If + End Sub + +End Class + +'======================================================================================================================= +' MIGRATION CONTEXT +'======================================================================================================================= +' Provides helper methods for use within migration files +' +Class MigrationContext_Class + Public DB ' Reference to DAL + + '------------------------------------------------------------------------------------------------------------------- + ' Execute raw SQL + '------------------------------------------------------------------------------------------------------------------- + Public Sub ExecuteSQL(sql) + DB.Execute sql, empty + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Create a table + '------------------------------------------------------------------------------------------------------------------- + Public Sub CreateTable(tableName, columns) + Dim sql + sql = "CREATE TABLE " & tableName & " (" & columns & ")" + ExecuteSQL sql + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Drop a table + '------------------------------------------------------------------------------------------------------------------- + Public Sub DropTable(tableName) + ExecuteSQL "DROP TABLE " & tableName + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Add a column to a table + '------------------------------------------------------------------------------------------------------------------- + Public Sub AddColumn(tableName, columnName, columnType) + ExecuteSQL "ALTER TABLE " & tableName & " ADD COLUMN " & columnName & " " & columnType + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Drop a column from a table + '------------------------------------------------------------------------------------------------------------------- + Public Sub DropColumn(tableName, columnName) + ExecuteSQL "ALTER TABLE " & tableName & " DROP COLUMN " & columnName + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Create an index + '------------------------------------------------------------------------------------------------------------------- + Public Sub CreateIndex(indexName, tableName, columns) + ExecuteSQL "CREATE INDEX " & indexName & " ON " & tableName & " (" & columns & ")" + End Sub + + '------------------------------------------------------------------------------------------------------------------- + ' Drop an index + '------------------------------------------------------------------------------------------------------------------- + Public Sub DropIndex(indexName, tableName) + ExecuteSQL "DROP INDEX " & indexName & " ON " & tableName + End Sub +End Class + +'======================================================================================================================= +' SINGLETON +'======================================================================================================================= +Dim Migrator__Singleton : Set Migrator__Singleton = Nothing + +Function Migrator() + If Migrator__Singleton Is Nothing Then + Set Migrator__Singleton = New Migrator_Class + End If + Set Migrator = Migrator__Singleton +End Function +%> diff --git a/core/lib.Routes.asp b/core/lib.Routes.asp new file mode 100644 index 0000000..247c0f0 --- /dev/null +++ b/core/lib.Routes.asp @@ -0,0 +1,262 @@ +<% +'======================================================================================================================= +' ROUTING HELPER +' Provides URL generation for RouteKit framework +'======================================================================================================================= +Class Route_Helper_Class + Private m_app_url + Private m_content_url + Private m_stylesheets_url + Private m_js_url + Private m_images_url + Private m_enable_cache_busting + Private m_cache_bust_param_name + + Private Sub Class_Initialize() + ' Auto-detect application URL from current request + Dim protocol, host, appPath + protocol = IIf(Request.ServerVariables("HTTPS") = "on", "https://", "http://") + host = Request.ServerVariables("HTTP_HOST") + appPath = Request.ServerVariables("APPL_MD_PATH") + + ' Extract virtual directory from IIS path + Dim vdir + vdir = "" + If InStr(appPath, "/LM/W3SVC/") > 0 Then + vdir = Mid(appPath, InStrRev(appPath, "/") + 1) + If vdir <> "ROOT" Then + vdir = "/" & vdir + Else + vdir = "" + End If + End If + + m_app_url = protocol & host & vdir & "/" + m_content_url = m_app_url & "content/" + m_stylesheets_url = m_app_url & "css/" + m_js_url = m_app_url & "js/" + m_images_url = m_app_url & "images/" + + ' Load cache-busting configuration + Dim cacheBustSetting + cacheBustSetting = GetAppSetting("EnableCacheBusting") + m_enable_cache_busting = (cacheBustSetting = "true" Or cacheBustSetting = "True") + + ' Get cache-bust parameter name (default: "v") + m_cache_bust_param_name = GetAppSetting("CacheBustParamName") + If m_cache_bust_param_name = "nothing" Or Len(m_cache_bust_param_name) = 0 Then + m_cache_bust_param_name = "v" + End If + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Cache-busting token (timestamp-based for uniqueness) + '--------------------------------------------------------------------------------------------------------------------- + Public Property Get NoCacheToken + NoCacheToken = CLng(Timer() * 100) + End Property + + '--------------------------------------------------------------------------------------------------------------------- + ' Check if cache-busting is globally enabled + '--------------------------------------------------------------------------------------------------------------------- + Public Property Get CacheBustingEnabled + CacheBustingEnabled = m_enable_cache_busting + End Property + + '--------------------------------------------------------------------------------------------------------------------- + ' Get/Set cache-busting enabled (can override config at runtime) + '--------------------------------------------------------------------------------------------------------------------- + Public Property Let CacheBustingEnabled(value) + m_enable_cache_busting = value + End Property + + '--------------------------------------------------------------------------------------------------------------------- + ' URL Properties + '--------------------------------------------------------------------------------------------------------------------- + Public Property Get AppURL + AppURL = m_app_url + End Property + + Public Property Get ContentURL + ContentURL = m_content_url + End Property + + Public Property Get StylesheetsURL + StylesheetsURL = m_stylesheets_url + End Property + + Public Property Get JsURL + JsURL = m_js_url + End Property + + Public Property Get ImagesURL + ImagesURL = m_images_url + End Property + + '--------------------------------------------------------------------------------------------------------------------- + ' Generate clean URL for controller/action (RouteKit style) + ' + ' @param controller_name String Name of controller (without "Controller" suffix) + ' @param action_name String Name of action method + ' @param params_array KV Array Optional key/value pair array for query string + ' @returns String Clean URL like "/controller/action?key=val" + '--------------------------------------------------------------------------------------------------------------------- + Public Function UrlTo(controller_name, action_name, params_array) + Dim url, qs + + ' Build clean URL: /controller/action + url = m_app_url & LCase(controller_name) & "/" & LCase(action_name) + + ' Add query string parameters if provided + qs = TO_Querystring(params_array) + If Len(qs) > 0 Then + url = url & "?" & qs + End If + + UrlTo = url + End Function + + '--------------------------------------------------------------------------------------------------------------------- + ' Generate URL with route parameters (e.g., /users/show/123) + ' + ' @param controller_name String Name of controller + ' @param action_name String Name of action method + ' @param route_params Array Route parameters (e.g., Array(123) for ID) + ' @param query_params KV Array Optional query string parameters + ' @returns String URL with route params + '--------------------------------------------------------------------------------------------------------------------- + Public Function UrlToWithParams(controller_name, action_name, route_params, query_params) + Dim url, qs, i + + ' Build base URL + url = m_app_url & LCase(controller_name) & "/" & LCase(action_name) + + ' Append route parameters + If IsArray(route_params) Then + For i = 0 To UBound(route_params) + url = url & "/" & Server.URLEncode(CStr(route_params(i))) + Next + ElseIf Not IsEmpty(route_params) Then + url = url & "/" & Server.URLEncode(CStr(route_params)) + End If + + ' Add query string parameters if provided + qs = TO_Querystring(query_params) + If Len(qs) > 0 Then + url = url & "?" & qs + End If + + UrlToWithParams = url + End Function + + '--------------------------------------------------------------------------------------------------------------------- + ' Generate URL for static asset with cache-busting + ' + ' @param asset_path String Relative path to asset (e.g., "css/site.css") + ' @param use_cache_bust Variant Boolean or Empty. If Empty, uses global setting. If True/False, overrides. + ' @returns String Full URL to asset + '--------------------------------------------------------------------------------------------------------------------- + Public Function AssetUrl(asset_path, use_cache_bust) + Dim url, shouldBust + url = m_app_url & asset_path + + ' Determine if we should cache-bust + If IsEmpty(use_cache_bust) Then + shouldBust = m_enable_cache_busting + Else + shouldBust = CBool(use_cache_bust) + End If + + If shouldBust Then + url = AppendCacheBustParam(url) + End If + + AssetUrl = url + End Function + + '--------------------------------------------------------------------------------------------------------------------- + ' Generate URL for route with optional cache-busting + ' + ' @param controller_name String Name of controller + ' @param action_name String Name of action + ' @param params_array KV Array Optional query params + ' @param use_cache_bust Variant Boolean or Empty. If Empty, uses global setting + ' @returns String URL with optional cache-busting + '--------------------------------------------------------------------------------------------------------------------- + Public Function UrlToWithCacheBust(controller_name, action_name, params_array, use_cache_bust) + Dim url + url = UrlTo(controller_name, action_name, params_array) + + ' Determine if we should cache-bust + Dim shouldBust + If IsEmpty(use_cache_bust) Then + shouldBust = m_enable_cache_busting + Else + shouldBust = CBool(use_cache_bust) + End If + + If shouldBust Then + url = AppendCacheBustParam(url) + End If + + UrlToWithCacheBust = url + End Function + + + '--------------------------------------------------------------------------------------------------------------------- + ' PRIVATE HELPER METHODS + '--------------------------------------------------------------------------------------------------------------------- + Private Function TO_Querystring(the_array) + Dim result, idx + result = "" + + If Not IsEmpty(the_array) And IsArray(the_array) Then + ' Process key-value pairs (array with even number of elements) + For idx = LBound(the_array) To UBound(the_array) Step 2 + If idx + 1 <= UBound(the_array) Then + result = result & GetParam(the_array, idx) + ' Append & between parameters, but not on the last parameter + If Not (idx >= UBound(the_array) - 1) Then + result = result & "&" + End If + End If + Next + End If + + TO_Querystring = result + End Function + + Private Function GetParam(params_array, key_idx) + Dim key, val + key = Server.URLEncode(CStr(params_array(key_idx))) + val = Server.URLEncode(CStr(params_array(key_idx + 1))) + GetParam = key & "=" & val + End Function + + Private Function AppendCacheBustParam(url) + Dim separator + ' Determine if we need ? or & + If InStr(url, "?") > 0 Then + separator = "&" + Else + separator = "?" + End If + AppendCacheBustParam = url & separator & m_cache_bust_param_name & "=" & NoCacheToken + End Function +End Class + + +'--------------------------------------------------------------------------------------------------------------------- +' Singleton accessor +'--------------------------------------------------------------------------------------------------------------------- +Dim Route_Helper__Singleton +Set Route_Helper__Singleton = Nothing + +Function Routes() + If Route_Helper__Singleton Is Nothing Then + Set Route_Helper__Singleton = New Route_Helper_Class + End If + Set Routes = Route_Helper__Singleton +End Function + +%> diff --git a/core/lib.Strings.asp b/core/lib.Strings.asp new file mode 100644 index 0000000..7b2550f --- /dev/null +++ b/core/lib.Strings.asp @@ -0,0 +1,73 @@ +<% +'======================================================================================================================= +' StringBuilder Class +'======================================================================================================================= +Class StringBuilder_Class + dim m_array + dim m_array_size + dim m_cur_pos + + Private Sub Class_Initialize + m_array = Array + m_array_size = 100 + redim m_array(m_array_size) + m_cur_pos = -1 + End Sub + + Private Sub Extend + m_array_size = m_array_size + 100 + redim preserve m_array(m_array_size) + End Sub + + Public Sub Add(s) + m_cur_pos = m_cur_pos + 1 + m_array(m_cur_pos) = s + if m_cur_pos = m_array_size then Extend + End Sub + + Public Function [Get](delim) + 'have to create a new array containing only the slots actually used, otherwise Join() happily adds delim + 'for *every* slot even the unused ones... + dim new_array : new_array = Array() + redim new_array(m_cur_pos) + dim i + for i = 0 to m_cur_pos + new_array(i) = m_array(i) + next + [Get] = Join(new_array, delim) + End Function + + Public Default Property Get TO_String + TO_String = Join(m_array, "") + End Property +End Class + +Function StringBuilder() + set StringBuilder = new StringBuilder_Class +End Function + + +'======================================================================================================================= +' Misc +'======================================================================================================================= +Function Excerpt(text, length) + Excerpt = Left(text, length) & " ..." +End Function + +Function IsBlank(text) + If IsObject(text) then + If text Is Nothing then + IsBlank = true + Else + IsBlank = false + End If + Else + If IsEmpty(text) or IsNull(text) or Len(text) = 0 then + IsBlank = true + Else + IsBlank = false + End If + End If +End Function + +%> diff --git a/core/lib.Upload.asp b/core/lib.Upload.asp new file mode 100644 index 0000000..7cf583c --- /dev/null +++ b/core/lib.Upload.asp @@ -0,0 +1,405 @@ + + + +<% +' For examples, documentation, and your own free copy, go to: +' http://www.freeaspupload.net +' Note: You can copy and use this script for free and you can make changes +' to the code, but you cannot remove the above comment. + +'Changes: +'Aug 2, 2005: Add support for checkboxes and other input elements with multiple values +'Jan 6, 2009: Lars added ASP_CHUNK_SIZE + +const DEFAULT_ASP_CHUNK_SIZE = 200000 + +Class FreeASPUpload + Public UploadedFiles + Public FormElements + + Private VarArrayBinRequest + Private StreamRequest + Private uploadedYet + Private internalChunkSize + + Private Sub Class_Initialize() + Set UploadedFiles = Server.CreateObject("Scripting.Dictionary") + Set FormElements = Server.CreateObject("Scripting.Dictionary") + Set StreamRequest = Server.CreateObject("ADODB.Stream") + StreamRequest.Type = 2 ' adTypeText + StreamRequest.Open + uploadedYet = false + internalChunkSize = DEFAULT_ASP_CHUNK_SIZE + End Sub + + Private Sub Class_Terminate() + If IsObject(UploadedFiles) Then + UploadedFiles.RemoveAll() + Set UploadedFiles = Nothing + End If + If IsObject(FormElements) Then + FormElements.RemoveAll() + Set FormElements = Nothing + End If + StreamRequest.Close + Set StreamRequest = Nothing + End Sub + + Public Property Get Form(sIndex) + Form = "" + If FormElements.Exists(LCase(sIndex)) Then Form = FormElements.Item(LCase(sIndex)) + End Property + + Public Property Get Files() + Files = UploadedFiles.Items + End Property + +Public Property Get Exists(sIndex) +Exists = false +If FormElements.Exists(LCase(sIndex)) Then Exists = true +End Property + +Public Property Get FileExists(sIndex) +FileExists = false +if UploadedFiles.Exists(LCase(sIndex)) then FileExists = true +End Property + +Public Property Get chunkSize() + chunkSize = internalChunkSize + End Property + + Public Property Let chunkSize(sz) + internalChunkSize = sz + End Property + + 'Calls Upload to extract the data from the binary request and then saves the uploaded files + Public Sub Save(path) + Dim streamFile, fileItem + + if Right(path, 1) <> "\" then path = path & "\" + + if not uploadedYet then Upload + + For Each fileItem In UploadedFiles.Items + Set streamFile = Server.CreateObject("ADODB.Stream") + streamFile.Type = 1 + streamFile.Open + StreamRequest.Position=fileItem.Start + StreamRequest.CopyTo streamFile, fileItem.Length + streamFile.SaveToFile path & fileItem.FileName, 2 + streamFile.close + Set streamFile = Nothing + fileItem.Path = path & fileItem.FileName + Next + End Sub + + public sub SaveOne(path, num, byref outFileName, byref outLocalFileName) + Dim streamFile, fileItems, fileItem, fs + +set fs = Server.CreateObject("Scripting.FileSystemObject") + if Right(path, 1) <> "\" then path = path & "\" + + if not uploadedYet then Upload + if UploadedFiles.Count > 0 then + fileItems = UploadedFiles.Items + set fileItem = fileItems(num) + + outFileName = fileItem.FileName + outLocalFileName = GetFileName(path, outFileName) + + Set streamFile = Server.CreateObject("ADODB.Stream") + streamFile.Type = 1 + streamFile.Open + StreamRequest.Position = fileItem.Start + StreamRequest.CopyTo streamFile, fileItem.Length + streamFile.SaveToFile path & outLocalFileName, 2 + streamFile.close + Set streamFile = Nothing + fileItem.Path = path & filename + end if + end sub + + Public Function SaveBinRequest(path) ' For debugging purposes + StreamRequest.SaveToFile path & "\debugStream.bin", 2 + End Function + + Public Sub DumpData() 'only works if files are plain text + Dim i, aKeys, f + response.write "Form Items:
" + aKeys = FormElements.Keys + For i = 0 To FormElements.Count -1 ' Iterate the array + response.write aKeys(i) & " = " & FormElements.Item(aKeys(i)) & "
" + Next + response.write "Uploaded Files:
" + For Each f In UploadedFiles.Items + response.write "Name: " & f.FileName & "
" + response.write "Type: " & f.ContentType & "
" + response.write "Start: " & f.Start & "
" + response.write "Size: " & f.Length & "
" + Next + End Sub + + Public Sub Upload() + Dim nCurPos, nDataBoundPos, nLastSepPos + Dim nPosFile, nPosBound + Dim sFieldName, osPathSep, auxStr + Dim readBytes, readLoop, tmpBinRequest + + 'RFC1867 Tokens + Dim vDataSep + Dim tNewLine, tDoubleQuotes, tTerm, tFilename, tName, tContentDisp, tContentType + tNewLine = String2Byte(Chr(13)) + tDoubleQuotes = String2Byte(Chr(34)) + tTerm = String2Byte("--") + tFilename = String2Byte("filename=""") + tName = String2Byte("name=""") + tContentDisp = String2Byte("Content-Disposition") + tContentType = String2Byte("Content-Type:") + + uploadedYet = true + + on error resume next + readBytes = internalChunkSize + VarArrayBinRequest = Request.BinaryRead(readBytes) + VarArrayBinRequest = midb(VarArrayBinRequest, 1, lenb(VarArrayBinRequest)) + for readLoop = 0 to 300000 + tmpBinRequest = Request.BinaryRead(readBytes) + if readBytes < 1 then exit for + VarArrayBinRequest = VarArrayBinRequest & midb(tmpBinRequest, 1, lenb(tmpBinRequest)) + next + if Err.Number <> 0 then + response.write "

System reported this error:

" + response.write Err.Description & "

" + response.write "The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the requirements page of freeaspupload.net.

" + Exit Sub + end if + on error goto 0 'reset error handling + + nCurPos = FindToken(tNewLine,1) 'Note: nCurPos is 1-based (and so is InstrB, MidB, etc) + + If nCurPos <= 1 Then Exit Sub + + 'vDataSep is a separator like -----------------------------21763138716045 + vDataSep = MidB(VarArrayBinRequest, 1, nCurPos-1) + + 'Start of current separator + nDataBoundPos = 1 + + 'Beginning of last line + nLastSepPos = FindToken(vDataSep & tTerm, 1) + + Do Until nDataBoundPos = nLastSepPos + + nCurPos = SkipToken(tContentDisp, nDataBoundPos) + nCurPos = SkipToken(tName, nCurPos) + sFieldName = ExtractField(tDoubleQuotes, nCurPos) + + nPosFile = FindToken(tFilename, nCurPos) + nPosBound = FindToken(vDataSep, nCurPos) + + If nPosFile <> 0 And nPosFile < nPosBound Then + Dim oUploadFile + Set oUploadFile = New UploadedFile + + nCurPos = SkipToken(tFilename, nCurPos) + auxStr = ExtractField(tDoubleQuotes, nCurPos) +' We are interested only in the name of the file, not the whole path +' Path separator is \ in windows, / in UNIX +' While IE seems to put the whole pathname in the stream, Mozilla seem to +' only put the actual file name, so UNIX paths may be rare. But not impossible. +osPathSep = "\" +if InStr(auxStr, osPathSep) = 0 then osPathSep = "/" + oUploadFile.FileName = Right(auxStr, Len(auxStr)-InStrRev(auxStr, osPathSep)) + + if (Len(oUploadFile.FileName) > 0) then 'File field not left empty + nCurPos = SkipToken(tContentType, nCurPos) + +auxStr = ExtractField(tNewLine, nCurPos) +' NN on UNIX puts things like this in the stream: +' ?? python py type=?? python application/x-python + oUploadFile.ContentType = Right(auxStr, Len(auxStr)-InStrRev(auxStr, " ")) + nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line + + oUploadFile.Start = nCurPos+1 + oUploadFile.Length = FindToken(vDataSep, nCurPos) - 2 - nCurPos + + If oUploadFile.Length > 0 Then UploadedFiles.Add LCase(sFieldName), oUploadFile + End If + Else + Dim nEndOfData + nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line + nEndOfData = FindToken(vDataSep, nCurPos) - 2 + If Not FormElements.Exists(LCase(sFieldName)) Then + FormElements.Add LCase(sFieldName), Byte2String(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos)) + else +FormElements.Item(LCase(sFieldName))= FormElements.Item(LCase(sFieldName)) & ", " & Byte2String(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos)) +end if + + End If + + 'Advance to next separator + nDataBoundPos = FindToken(vDataSep, nCurPos) + Loop + StreamRequest.WriteText(VarArrayBinRequest) + End Sub + + Private Function SkipToken(sToken, nStart) + SkipToken = InstrB(nStart, VarArrayBinRequest, sToken) + If SkipToken = 0 then + Response.write "Error in parsing uploaded binary request. The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the requirements page of freeaspupload.net.

" + Response.End + end if + SkipToken = SkipToken + LenB(sToken) + End Function + + Private Function FindToken(sToken, nStart) + FindToken = InstrB(nStart, VarArrayBinRequest, sToken) + End Function + + Private Function ExtractField(sToken, nStart) + Dim nEnd + nEnd = InstrB(nStart, VarArrayBinRequest, sToken) + If nEnd = 0 then + Response.write "Error in parsing uploaded binary request." + Response.End + end if + ExtractField = Byte2String(MidB(VarArrayBinRequest, nStart, nEnd-nStart)) + End Function + + 'String to byte string conversion + Private Function String2Byte(sString) + Dim i + For i = 1 to Len(sString) + String2Byte = String2Byte & ChrB(AscB(Mid(sString,i,1))) + Next + End Function + + 'Byte string to string conversion + Private Function Byte2String(bsString) + Dim i + dim b1, b2, b3, b4 + Byte2String ="" + For i = 1 to LenB(bsString) + if AscB(MidB(bsString,i,1)) < 128 then + ' One byte + Byte2String = Byte2String & ChrW(AscB(MidB(bsString,i,1))) + elseif AscB(MidB(bsString,i,1)) < 224 then + ' Two bytes + b1 = AscB(MidB(bsString,i,1)) + b2 = AscB(MidB(bsString,i+1,1)) + Byte2String = Byte2String & ChrW((((b1 AND 28) / 4) * 256 + (b1 AND 3) * 64 + (b2 AND 63))) + i = i + 1 + elseif AscB(MidB(bsString,i,1)) < 240 then + ' Three bytes + b1 = AscB(MidB(bsString,i,1)) + b2 = AscB(MidB(bsString,i+1,1)) + b3 = AscB(MidB(bsString,i+2,1)) + Byte2String = Byte2String & ChrW(((b1 AND 15) * 16 + (b2 AND 60)) * 256 + (b2 AND 3) * 64 + (b3 AND 63)) + i = i + 2 + else + ' Four bytes + b1 = AscB(MidB(bsString,i,1)) + b2 = AscB(MidB(bsString,i+1,1)) + b3 = AscB(MidB(bsString,i+2,1)) + b4 = AscB(MidB(bsString,i+3,1)) + ' Don't know how to handle this, I believe Microsoft doesn't support these characters so I replace them with a "^" + 'Byte2String = Byte2String & ChrW(((b1 AND 3) * 64 + (b2 AND 63)) & "," & (((b1 AND 28) / 4) * 256 + (b1 AND 3) * 64 + (b2 AND 63))) + Byte2String = Byte2String & "^" + i = i + 3 + end if + Next + End Function +End Class + +Class UploadedFile + Public ContentType + Public Start + Public Length + Public Path + Private nameOfFile + +' Need to remove characters that are valid in UNIX, but not in Windows +Public Property Let FileName(fN) +nameOfFile = fN +nameOfFile = SubstNoReg(nameOfFile, "\", "_") +nameOfFile = SubstNoReg(nameOfFile, "/", "_") +nameOfFile = SubstNoReg(nameOfFile, ":", "_") +nameOfFile = SubstNoReg(nameOfFile, "*", "_") +nameOfFile = SubstNoReg(nameOfFile, "?", "_") +nameOfFile = SubstNoReg(nameOfFile, """", "_") +nameOfFile = SubstNoReg(nameOfFile, "<", "_") +nameOfFile = SubstNoReg(nameOfFile, ">", "_") +nameOfFile = SubstNoReg(nameOfFile, "|", "_") +End Property + +Public Property Get FileName() +FileName = nameOfFile +End Property + +'Public Property Get FileN()ame +End Class + + +' Does not depend on RegEx, which is not available on older VBScript +' Is not recursive, which means it will not run out of stack space +Function SubstNoReg(initialStr, oldStr, newStr) +Dim currentPos, oldStrPos, skip +If IsNull(initialStr) Or Len(initialStr) = 0 Then +SubstNoReg = "" +ElseIf IsNull(oldStr) Or Len(oldStr) = 0 Then +SubstNoReg = initialStr +Else +If IsNull(newStr) Then newStr = "" +currentPos = 1 +oldStrPos = 0 +SubstNoReg = "" +skip = Len(oldStr) +Do While currentPos <= Len(initialStr) +oldStrPos = InStr(currentPos, initialStr, oldStr) +If oldStrPos = 0 Then +SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, Len(initialStr) - currentPos + 1) +currentPos = Len(initialStr) + 1 +Else +SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, oldStrPos - currentPos) & newStr +currentPos = oldStrPos + skip +End If +Loop +End If +End Function + +Function GetFileName(strSaveToPath, FileName) +'This function is used when saving a file to check there is not already a file with the same name so that you don't overwrite it. +'It adds numbers to the filename e.g. file.gif becomes file1.gif becomes file2.gif and so on. +'It keeps going until it returns a filename that does not exist. +'You could just create a filename from the ID field but that means writing the record - and it still might exist! +'N.B. Requires strSaveToPath variable to be available - and containing the path to save to +Dim Counter +Dim Flag +Dim strTempFileName +Dim FileExt +Dim NewFullPath +dim objFSO, p +Set objFSO = CreateObject("Scripting.FileSystemObject") +Counter = 0 +p = instrrev(FileName, ".") +FileExt = mid(FileName, p+1) +strTempFileName = left(FileName, p-1) +NewFullPath = strSaveToPath & "\" & FileName +Flag = False + +Do Until Flag = True +If objFSO.FileExists(NewFullPath) = False Then +Flag = True +GetFileName = Mid(NewFullPath, InstrRev(NewFullPath, "\") + 1) +Else +Counter = Counter + 1 +NewFullPath = strSaveToPath & "\" & strTempFileName & Counter & "." & FileExt +End If +Loop +End Function +%> \ No newline at end of file diff --git a/core/lib.Validations.asp b/core/lib.Validations.asp new file mode 100644 index 0000000..62bdeb0 --- /dev/null +++ b/core/lib.Validations.asp @@ -0,0 +1,250 @@ +<% +'======================================================================================================================= +' Validation Classes +'======================================================================================================================= + +'----------------------------------------------------------------------------------------------------------------------- +' Exists Validation +'----------------------------------------------------------------------------------------------------------------------- +Class ExistsValidation_Class + Private m_instance + Private m_field_name + Private m_message + Private m_ok + + Public Function Initialize(instance, field_name, message) + set m_instance = instance + m_field_name = field_name + m_message = message + m_ok = true + set Initialize = Me + End Function + + Public Sub Check + If Len(eval("m_instance." & m_field_name)) = 0 then + m_ok = false + End If + End Sub + + Public Property Get OK + OK = m_ok + End Property + + Public Property Get Message + Message = m_message + End Property +End Class + +Sub ValidateExists(instance, field_name, message) + if not IsObject(instance.Validator) then set instance.Validator = new Validator_Class + instance.Validator.AddValidation new ExistsValidation_Class.Initialize(instance, field_name, message) +End Sub + + +'----------------------------------------------------------------------------------------------------------------------- +' Minimum Length Validation +'----------------------------------------------------------------------------------------------------------------------- +Class MinLengthValidation_Class + Private m_instance + Private m_field_name + Private m_size + Private m_message + Private m_ok + + Public Function Initialize(instance, field_name, size, message) + set m_instance = instance + m_field_name = field_name + m_size = size + m_message = message + m_ok = true + set Initialize = Me + End Function + + Public Sub Check + If Len(eval("m_instance." & m_field_name)) < m_size then m_ok = false + End Sub + + Public Property Get OK + OK = m_ok + End Property + + Public Property Get Message + Message = m_message + End Property +End Class + +Sub ValidateMinLength(instance, field_name, size, message) + if not IsObject(instance.Validator) then set instance.Validator = new Validator_Class + instance.Validator.AddValidation new MinLengthValidation_Class.Initialize(instance, field_name, size, message) +End Sub + +'----------------------------------------------------------------------------------------------------------------------- +' Max Length Validation +'----------------------------------------------------------------------------------------------------------------------- +Class MaxLengthValidation_Class + Private m_instance + Private m_field_name + Private m_size + Private m_message + Private m_ok + + Public Function Initialize(instance, field_name, size, message) + set m_instance = instance + m_field_name = field_name + m_size = size + m_message = message + m_ok = true + set Initialize = Me + End Function + + Public Sub Check + If Len(eval("m_instance." & m_field_name)) > m_size then m_ok = false + End Sub + + Public Property Get OK + OK = m_ok + End Property + + Public Property Get Message + Message = m_message + End Property +End Class + +Sub ValidateMaxLength(instance, field_name, size, message) + if not IsObject(instance.Validator) then set instance.Validator = new Validator_Class + instance.Validator.AddValidation new MaxLengthValidation_Class.Initialize(instance, field_name, size, message) +End Sub + +'----------------------------------------------------------------------------------------------------------------------- +' Numeric Validation +'----------------------------------------------------------------------------------------------------------------------- +Class NumericValidation_Class + Private m_instance + Private m_field_name + Private m_message + Private m_ok + + Public Function Initialize(instance, field_name, message) + set m_instance = instance + m_field_name = field_name + m_message = message + m_ok = true + set Initialize = Me + End Function + + Public Sub Check + If Not IsNumeric(eval("m_instance." & m_field_name)) then m_ok = false + End Sub + + Public Property Get OK + OK = m_ok + End Property + + Public Property Get Message + Message = m_message + End Property +End Class + +Sub ValidateNumeric(instance, field_name, message) + if not IsObject(instance.Validator) then set instance.Validator = new Validator_Class + instance.Validator.AddValidation new NumericValidation_Class.Initialize(instance, field_name, message) +End Sub + + +'----------------------------------------------------------------------------------------------------------------------- +' Regular Expression Pattern Validation +'----------------------------------------------------------------------------------------------------------------------- +Class PatternValidation_Class + Private m_instance + Private m_field_name + Private m_pattern + Private m_message + Private m_ok + + Public Function Initialize(instance, field_name, pattern, message) + set m_instance = instance + m_field_name = field_name + m_pattern = pattern + m_message = message + m_ok = true + set Initialize = Me + End Function + + Public Sub Check + dim re : set re = new RegExp + With re + .Pattern = m_pattern + .Global = true + .IgnoreCase = true + End With + dim matches : set matches = re.Execute(eval("m_instance." & m_field_name)) + if matches.Count = 0 then + m_ok = false + end if + End Sub + + Public Property Get OK + OK = m_ok + End Property + + Public Property Get Message + Message = m_message + End Property +End Class + +Sub ValidatePattern(instance, field_name, pattern, message) + if not IsObject(instance.Validator) then set instance.Validator = new Validator_Class + instance.Validator.AddValidation new PatternValidation_Class.Initialize(instance, field_name, pattern, message) +End Sub + + + +'----------------------------------------------------------------------------------------------------------------------- +' Validator Class +' This class is not intended to be used directly. Models should use the Validate* subs instead. +'----------------------------------------------------------------------------------------------------------------------- +Class Validator_Class + Private m_validations + Private m_errors + + Private Sub Class_Initialize + m_validations = Array() + redim m_validations(-1) + + m_errors = Array() + redim m_errors(-1) + End Sub + + Public Property Get Errors + Errors = m_errors + End Property + + Public Sub AddValidation(validation) + dim n : n = ubound(m_validations) + 1 + redim preserve m_validations(n) + set m_validations(n) = validation + End Sub + + Public Sub Validate + dim n : n = ubound(m_validations) + dim i, V + for i = 0 to n + set V = m_validations(i) + V.Check + if not V.OK then + AddError V.Message + end if + next + End Sub + + Public Property Get HasErrors + HasErrors = (ubound(m_errors) > -1) + End Property + + 'Public to allow other errors to be added by the controller for circumstances not accounted for by the validators + Public Sub AddError(msg) + redim preserve m_errors(ubound(m_errors) + 1) + m_errors(ubound(m_errors)) = msg + End Sub +End Class +%> \ No newline at end of file diff --git a/core/lib.ad.auth.asp b/core/lib.ad.auth.asp new file mode 100644 index 0000000..edb615c --- /dev/null +++ b/core/lib.ad.auth.asp @@ -0,0 +1,52 @@ +<% +'========================== +' AD_Auth_Class.asp +'========================== +Class AD_Auth_Class + Public DomainName ' e.g. yourdomain.local + Public ContainerDN ' e.g. DC=yourdomain,DC=local + Public Username + Public Password + Public ErrorMessage + Public IsAuthenticated + Public UserObject + + Private Sub Class_Initialize() + IsAuthenticated = False + ErrorMessage = "" + Set UserObject = Nothing + End Sub + + Public Function Authenticate() + On Error Resume Next + + Dim ldapPath, userCredential + ldapPath = "LDAP://" & ContainerDN ' Must be DC=yourdomain,DC=local + userCredential = DomainName & "\" & Username + + ' Try to bind to Active Directory + Dim rootDSE : Set rootDSE = GetObject("LDAP:") + Set UserObject = rootDSE.OpenDSObject(ldapPath, userCredential, Password, 1) + + If Err.Number <> 0 Then + ErrorMessage = "Authentication failed: " & Err.Description + IsAuthenticated = False + Set UserObject = Nothing + Else + IsAuthenticated = True + ErrorMessage = "" + End If + + Authenticate = IsAuthenticated + On Error GoTo 0 + End Function +End Class + +dim AD_Auth_Class__Singleton +Function AdAuth() + if IsEmpty(AD_Auth_Class__Singleton) then + set AD_Auth_Class__Singleton = new AD_Auth_Class + end if + set AdAuth = AD_Auth_Class__Singleton +End Function +%> diff --git a/core/lib.crypto.helper.asp b/core/lib.crypto.helper.asp new file mode 100644 index 0000000..e6bdd54 --- /dev/null +++ b/core/lib.crypto.helper.asp @@ -0,0 +1,45 @@ +<% + +Function HashPassword(password) + Dim shell, command, execObj, outputLine, result + + ' Create Shell Object + Set shell = CreateObject("WScript.Shell") + + ' Construct PowerShell Command + + command = "cmd /c powershell -ExecutionPolicy Bypass -NoLogo -NoProfile -File """ & Server.MapPath(".") & "..\Core\hash_sha256.ps1"" -password " & password + ' Execute Command + Set execObj = shell.Exec(command) + + ' Read Output + Do While Not execObj.StdOut.AtEndOfStream + outputLine = Trim(execObj.StdOut.ReadAll()) + If outputLine <> "" Then + result = outputLine ' Capture the hash + End If + Loop + + ' Cleanup + Set shell = Nothing + Set execObj = Nothing + + ' Return the hash or error message + If result = "" Or Left(result, 5) = "ERROR" Then + HashPassword = result ' "ERROR: Hash not generated" + Else + HashPassword = result + End If +End Function + +Function CheckPassword(username, password) + Dim user,UsersRepository + Set UsersRepository = CreateRepository(conn, "Users", "UserId") + ' Find User + Set User = UsersRepository.Find(Array("UserName", user), Empty) + If user Is Nothing Then Exit Function ' Implicitly returns False + + ' Compare Hashed Password + CheckPassword = (HashPassword(password) = user.PasswordHash) +End Function +%> \ No newline at end of file diff --git a/core/lib.helpers.asp b/core/lib.helpers.asp new file mode 100644 index 0000000..b2ae6d6 --- /dev/null +++ b/core/lib.helpers.asp @@ -0,0 +1,115 @@ +<% +'protocol = IIf(LCase(Request.ServerVariables("HTTPS")) = "1", "https", "http") +protocol = "https" +Dim timeZones +timeZones = Array( _ + Array("America/New_York", "Eastern (New York)"), _ + Array("America/Chicago", "Central (Chicago)"), _ + Array("America/Denver", "Mountain (Denver)"), _ + Array("America/Los_Angeles", "Pacific (Los Angeles)"), _ + Array("Europe/London", "London (UK)") _ +) + +Function RequestBinary() + On Error Resume Next + Dim stream, rawData + + If Request.TotalBytes = 0 Then + RequestBinary = "" + Exit Function + End If + + Set stream = Server.CreateObject("ADODB.Stream") + stream.Type = 1 ' adTypeBinary + stream.Open + stream.Write Request.BinaryRead(Request.TotalBytes) + + stream.Position = 0 + stream.Type = 2 ' adTypeText + stream.Charset = "utf-8" + rawData = stream.ReadText + + stream.Close + Set stream = Nothing + + If Err.Number <> 0 Then + rawData = "" + Err.Clear + End If + + On Error GoTo 0 + RequestBinary = rawData +End Function + +Function ArrayContains(arr, val) + Dim i + ArrayContains = False + If IsArray(arr) Then + For i = LBound(arr) To UBound(arr) + If arr(i) = val Then + ArrayContains = True + Exit Function + End If + Next + End If +End Function + +Function RenderPOBOArrayAsJson(pobo) + Dim i, j, obj, propList, propName, json, propVal, line,poboArray + if IsLinkedList(pobo) Then + poboArray = pobo.TO_Array() + End If + json = "[" + + If IsEmpty(poboArray) Then + RenderPOBOArrayAsJson = "[]" + Exit Function + End If + + For i = 0 To UBound(poboArray) + Set obj = poboArray(i) + propList = obj.Properties + line = "{" + + For j = 0 To UBound(propList) + propName = propList(j) + ' Dynamically get value using Execute + Execute "propVal = obj." & propName + + Select Case VarType(propVal) + Case vbString + line = line & """" & propName & """:""" & JsonEscape(propVal) & """" + Case vbBoolean + line = line & """" & propName & """:" & LCase(CStr(propVal)) + Case vbDate + line = line & """" & propName & """:""" & Replace(CStr(propVal), """", "") & """" + Case vbNull + line = line & """" & propName & """:null" + Case Else + line = line & """" & propName & """:" & CStr(propVal) + End Select + + If j < UBound(propList) Then + line = line & "," + End If + Next + + line = line & "}" + If i < UBound(poboArray) Then line = line & "," + json = json & line + Next + + json = json & "]" + RenderPOBOArrayAsJson = json +End Function + +Function JsonEscape(str) + str = Replace(str, "\", "\\") + str = Replace(str, """", "\""") + str = Replace(str, vbCrLf, "\n") + str = Replace(str, vbLf, "\n") + str = Replace(str, vbCr, "\n") + str = Replace(str, Chr(9), "\t") + JsonEscape = str +End Function +%> \ No newline at end of file diff --git a/core/lib.json.asp b/core/lib.json.asp new file mode 100644 index 0000000..38bef36 --- /dev/null +++ b/core/lib.json.asp @@ -0,0 +1,284 @@ +<% +'January 2021 - Version 1.1 by Gerrit van Kuipers +Class aspJSON + Public data + Private p_JSONstring + Private aj_in_string, aj_in_escape, aj_i_tmp, aj_char_tmp, aj_s_tmp, aj_line_tmp, aj_line, aj_lines, aj_currentlevel, aj_currentkey, aj_currentvalue, aj_newlabel, aj_XmlHttp, aj_RegExp, aj_colonfound + + Private Sub Class_Initialize() + Set data = Collection() + + Set aj_RegExp = New regexp + aj_RegExp.Pattern = "\s{0,}(\S{1}[\s,\S]*\S{1})\s{0,}" + aj_RegExp.Global = False + aj_RegExp.IgnoreCase = True + aj_RegExp.Multiline = True + End Sub + + Private Sub Class_Terminate() + Set data = Nothing + Set aj_RegExp = Nothing + End Sub + + Public Sub loadJSON(inputsource) + inputsource = aj_MultilineTrim(inputsource) + If Len(inputsource) = 0 Then Err.Raise 1, "loadJSON Error", "No data to load." + + Select Case Left(inputsource, 1) + Case "{", "[" + Case Else + Set aj_XmlHttp = Server.CreateObject("Msxml2.ServerXMLHTTP") + aj_XmlHttp.open "POST", inputsource, False + aj_XmlHttp.setRequestHeader "Content-Type", "text/json" + aj_XmlHttp.setRequestHeader "CharSet", "UTF-8" + aj_XmlHttp.Send + inputsource = aj_XmlHttp.responseText + Set aj_XmlHttp = Nothing + End Select + + p_JSONstring = CleanUpJSONstring(inputsource) + aj_lines = Split(p_JSONstring, Chr(13) & Chr(10)) + + Dim level(99) + aj_currentlevel = 1 + Set level(aj_currentlevel) = data + For Each aj_line In aj_lines + aj_currentkey = "" + aj_currentvalue = "" + If Instr(aj_line, ":") > 0 Then + aj_in_string = False + aj_in_escape = False + aj_colonfound = False + For aj_i_tmp = 1 To Len(aj_line) + If aj_in_escape Then + aj_in_escape = False + Else + Select Case Mid(aj_line, aj_i_tmp, 1) + Case """" + aj_in_string = Not aj_in_string + Case ":" + If Not aj_in_escape And Not aj_in_string Then + aj_currentkey = Left(aj_line, aj_i_tmp - 1) + aj_currentvalue = Mid(aj_line, aj_i_tmp + 1) + aj_colonfound = True + Exit For + End If + Case "\" + aj_in_escape = True + End Select + End If + Next + if aj_colonfound then + aj_currentkey = aj_Strip(aj_JSONDecode(aj_currentkey), """") + If Not level(aj_currentlevel).exists(aj_currentkey) Then level(aj_currentlevel).Add aj_currentkey, "" + end if + End If + If right(aj_line,1) = "{" Or right(aj_line,1) = "[" Then + If Len(aj_currentkey) = 0 Then aj_currentkey = level(aj_currentlevel).Count + Set level(aj_currentlevel).Item(aj_currentkey) = Collection() + Set level(aj_currentlevel + 1) = level(aj_currentlevel).Item(aj_currentkey) + aj_currentlevel = aj_currentlevel + 1 + aj_currentkey = "" + ElseIf right(aj_line,1) = "}" Or right(aj_line,1) = "]" or right(aj_line,2) = "}," Or right(aj_line,2) = "]," Then + aj_currentlevel = aj_currentlevel - 1 + ElseIf Len(Trim(aj_line)) > 0 Then + If Len(aj_currentvalue) = 0 Then aj_currentvalue = aj_line + aj_currentvalue = getJSONValue(aj_currentvalue) + + If Len(aj_currentkey) = 0 Then aj_currentkey = level(aj_currentlevel).Count + level(aj_currentlevel).Item(aj_currentkey) = aj_currentvalue + End If + Next + End Sub + + Public Function Collection() + Set Collection = Server.CreateObject("Scripting.Dictionary") + End Function + + Public Function AddToCollection(dictobj) + If TypeName(dictobj) <> "Dictionary" Then Err.Raise 1, "AddToCollection Error", "Not a collection." + aj_newlabel = dictobj.Count + dictobj.Add aj_newlabel, Collection() + Set AddToCollection = dictobj.item(aj_newlabel) + end function + + Private Function CleanUpJSONstring(aj_originalstring) + aj_originalstring = Replace(aj_originalstring, Chr(13) & Chr(10), "") + aj_originalstring = Mid(aj_originalstring, 2, Len(aj_originalstring) - 2) + aj_in_string = False : aj_in_escape = False : aj_s_tmp = "" + For aj_i_tmp = 1 To Len(aj_originalstring) + aj_char_tmp = Mid(aj_originalstring, aj_i_tmp, 1) + If aj_in_escape Then + aj_in_escape = False + aj_s_tmp = aj_s_tmp & aj_char_tmp + Else + Select Case aj_char_tmp + Case "\" : aj_s_tmp = aj_s_tmp & aj_char_tmp : aj_in_escape = True + Case """" : aj_s_tmp = aj_s_tmp & aj_char_tmp : aj_in_string = Not aj_in_string + Case "{", "[" + aj_s_tmp = aj_s_tmp & aj_char_tmp & aj_InlineIf(aj_in_string, "", Chr(13) & Chr(10)) + Case "}", "]" + aj_s_tmp = aj_s_tmp & aj_InlineIf(aj_in_string, "", Chr(13) & Chr(10)) & aj_char_tmp + Case "," : aj_s_tmp = aj_s_tmp & aj_char_tmp & aj_InlineIf(aj_in_string, "", Chr(13) & Chr(10)) + Case Else : aj_s_tmp = aj_s_tmp & aj_char_tmp + End Select + End If + Next + + CleanUpJSONstring = "" + aj_s_tmp = Split(aj_s_tmp, Chr(13) & Chr(10)) + For Each aj_line_tmp In aj_s_tmp + aj_line_tmp = Replace(Replace(aj_line_tmp, Chr(10), ""), Chr(13), "") + CleanUpJSONstring = CleanUpJSONstring & aj_Trim(aj_line_tmp) & Chr(13) & Chr(10) + Next + End Function + + Private Function getJSONValue(ByVal val) + val = Trim(val) + If Left(val,1) = ":" Then val = Mid(val, 2) + If Right(val,1) = "," Then val = Left(val, Len(val) - 1) + val = Trim(val) + + Select Case val + Case "true" : getJSONValue = True + Case "false" : getJSONValue = False + Case "null" : getJSONValue = Null + Case Else + If (Instr(val, """") = 0) Then + If IsNumeric(val) Then + getJSONValue = aj_ReadNumericValue(val) + Else + getJSONValue = val + End If + Else + If Left(val,1) = """" Then val = Mid(val, 2) + If Right(val,1) = """" Then val = Left(val, Len(val) - 1) + getJSONValue = aj_JSONDecode(Trim(val)) + End If + End Select + End Function + + Private JSONoutput_level + Public Function JSONoutput() + Dim wrap_dicttype, aj_label + JSONoutput_level = 1 + wrap_dicttype = "[]" + For Each aj_label In data + If Not aj_IsInt(aj_label) Then wrap_dicttype = "{}" + Next + JSONoutput = Left(wrap_dicttype, 1) & Chr(13) & Chr(10) & GetDict(data) & Right(wrap_dicttype, 1) + End Function + + Private Function GetDict(objDict) + Dim aj_item, aj_keyvals, aj_label, aj_dicttype + For Each aj_item In objDict + Select Case TypeName(objDict.Item(aj_item)) + Case "Dictionary" + GetDict = GetDict & Space(JSONoutput_level * 4) + + aj_dicttype = "[]" + For Each aj_label In objDict.Item(aj_item).Keys + If Not aj_IsInt(aj_label) Then aj_dicttype = "{}" + Next + If aj_IsInt(aj_item) Then + GetDict = GetDict & (Left(aj_dicttype,1) & Chr(13) & Chr(10)) + Else + GetDict = GetDict & ("""" & aj_JSONEncode(aj_item) & """" & ": " & Left(aj_dicttype,1) & Chr(13) & Chr(10)) + End If + JSONoutput_level = JSONoutput_level + 1 + + aj_keyvals = objDict.Keys + GetDict = GetDict & (GetSubDict(objDict.Item(aj_item)) & Space(JSONoutput_level * 4) & Right(aj_dicttype,1) & aj_InlineIf(aj_item = aj_keyvals(objDict.Count - 1),"" , ",") & Chr(13) & Chr(10)) + Case Else + aj_keyvals = objDict.Keys + GetDict = GetDict & (Space(JSONoutput_level * 4) & aj_InlineIf(aj_IsInt(aj_item), "", """" & aj_JSONEncode(aj_item) & """: ") & WriteValue(objDict.Item(aj_item)) & aj_InlineIf(aj_item = aj_keyvals(objDict.Count - 1),"" , ",") & Chr(13) & Chr(10)) + End Select + Next + End Function + + Private Function aj_IsInt(val) + aj_IsInt = (TypeName(val) = "Integer" Or TypeName(val) = "Long") + End Function + + Private Function GetSubDict(objSubDict) + GetSubDict = GetDict(objSubDict) + JSONoutput_level= JSONoutput_level -1 + End Function + + Private Function WriteValue(ByVal val) + Select Case TypeName(val) + Case "Double", "Integer", "Long": WriteValue = replace(val, ",", ".") + Case "Null" : WriteValue = "null" + Case "Boolean" : WriteValue = aj_InlineIf(val, "true", "false") + Case Else : WriteValue = """" & aj_JSONEncode(val) & """" + End Select + End Function + + Private Function aj_JSONEncode(ByVal val) + val = Replace(val, "\", "\\") + val = Replace(val, """", "\""") + 'val = Replace(val, "/", "\/") + val = Replace(val, Chr(8), "\b") + val = Replace(val, Chr(12), "\f") + val = Replace(val, Chr(10), "\n") + val = Replace(val, Chr(13), "\r") + val = Replace(val, Chr(9), "\t") + aj_JSONEncode = Trim(val) + End Function + + Private Function aj_JSONDecode(ByVal val) + val = Replace(val, "\""", """") + val = Replace(val, "\\", "\") + val = Replace(val, "\/", "/") + val = Replace(val, "\b", Chr(8)) + val = Replace(val, "\f", Chr(12)) + val = Replace(val, "\n", Chr(10)) + val = Replace(val, "\r", Chr(13)) + val = Replace(val, "\t", Chr(9)) + aj_JSONDecode = Trim(val) + End Function + + Private Function aj_InlineIf(condition, returntrue, returnfalse) + If condition Then aj_InlineIf = returntrue Else aj_InlineIf = returnfalse + End Function + + Private Function aj_Strip(ByVal val, stripper) + If Left(val, 1) = stripper Then val = Mid(val, 2) + If Right(val, 1) = stripper Then val = Left(val, Len(val) - 1) + aj_Strip = val + End Function + + Private Function aj_MultilineTrim(TextData) + aj_MultilineTrim = aj_RegExp.Replace(TextData, "$1") + End Function + + Private Function aj_Trim(val) + aj_Trim = Trim(val) + Do While Left(aj_Trim, 1) = Chr(9) : aj_Trim = Mid(aj_Trim, 2) : Loop + Do While Right(aj_Trim, 1) = Chr(9) : aj_Trim = Left(aj_Trim, Len(aj_Trim) - 1) : Loop + aj_Trim = Trim(aj_Trim) + End Function + + Private Function aj_ReadNumericValue(ByVal val) + If Instr(val, ".") > 0 Then + numdecimals = Len(val) - Instr(val, ".") + val = Clng(Replace(val, ".", "")) + val = val / (10 ^ numdecimals) + aj_ReadNumericValue = val + Else + aj_ReadNumericValue = Clng(val) + End If + End Function +End Class + +dim json_Class__Singleton +Function json() + if IsEmpty(json_Class__Singleton) then + set json_Class__Singleton = new aspJSON + end if + set json = json_Class__Singleton +End Function + + + +%> \ No newline at end of file diff --git a/core/mvc.asp b/core/mvc.asp new file mode 100644 index 0000000..3417815 --- /dev/null +++ b/core/mvc.asp @@ -0,0 +1,173 @@ + +<% +' Set cache expiration from configuration +Dim cacheYear : cacheYear = GetAppSetting("CacheExpirationYear") +If cacheYear = "nothing" Then cacheYear = "2030" +Response.ExpiresAbsolute = "01/01/" & cacheYear +Response.AddHeader "pragma", "no-cache" +Response.AddHeader "cache-control", "private, no-cache, must-revalidate" +'======================================================================================================================= +' MVC Dispatcher +'======================================================================================================================= +Class MVC_Dispatcher_Class + dim CurrentController + + Public Property Get ControllerName + ControllerName = CurrentController + end Property + + '--------------------------------------------------------------------------------------------------------------------- + ' Convenience method to resolve route and dispatch in one call + ' method: HTTP method (GET, POST, etc.) + ' path: Request path (already cleaned of query params) + '--------------------------------------------------------------------------------------------------------------------- + Public Sub DispatchRequest(method, path) + Dim routeArray + routeArray = router.Resolve(method, path) + Dispatch routeArray + End Sub + + '--------------------------------------------------------------------------------------------------------------------- + ' Main dispatch method - executes a resolved route + ' RouteArray: Array(controller, action, params) from router.Resolve() + '--------------------------------------------------------------------------------------------------------------------- + Public Sub Dispatch(RouteArray) + On Error Resume Next + Dim controllerName, actionName, hasParams, paramsArray + controllerName = RouteArray(0) + actionName = RouteArray(1) + + ' A blank route is the router's no-match result. + If Len(Trim(controllerName)) = 0 Or Len(Trim(actionName)) = 0 Then + Response.Status = "404 Not Found" + Response.Write "Not Found" + Exit Sub + End If + + ' Security: Validate controller and action names + If Not ControllerRegistry.IsValidControllerFormat(controllerName) Then + Response.Write "

" + Response.Write "Security Error: Invalid controller name format." + Response.Write "
" + Exit Sub + End If + + If Not ControllerRegistry.IsValidActionFormat(actionName) Then + Response.Write "
" + Response.Write "Security Error: Invalid action name format." + Response.Write "
" + Exit Sub + End If + + ' Security: Check controller whitelist + If Not ControllerRegistry.IsValidController(controllerName) Then + Response.Write "
" + Response.Write "Security Error: Controller '" & Server.HTMLEncode(controllerName) & "' is not registered." + Response.Write "
" + Exit Sub + End If + + ' Initialize current controller + Dim controllerAssignment : controllerAssignment = "Set CurrentController = " & controllerName & "()" + Execute controllerAssignment + + ' Check if layout should be used + hasParams = (UBound(RouteArray) >= 2) + If eval(controllerName & ".useLayout") Then + %> <% + End If + + ' Prepare parameters + If hasParams Then + paramsArray = SurroundStringInArray(RouteArray(2)) + Else + paramsArray = Empty + End If + + ' Execute controller action + ExecuteControllerAction controllerName, actionName, paramsArray + + ' Include footer if layout is used + If eval(controllerName & ".useLayout") Then + %> <% + End If + On Error GoTo 0 + End Sub + + ' Helper method to execute controller actions (eliminates code duplication) + Private Sub ExecuteControllerAction(controllerName, actionName, paramsArray) + On Error Resume Next + Dim callString + + ' Build the call string based on whether we have parameters + If Not IsEmpty(paramsArray) And IsArray(paramsArray) And UBound(paramsArray) >= 0 Then + callString = "Call " & controllerName & "." & actionName & "(" & Join(paramsArray, ",") & ")" + Else + callString = "Call " & controllerName & "." & actionName & "()" + End If + + ' Execute the action + Execute callString + + ' Handle errors + If Err.Number <> 0 Then + HandleDispatchError actionName, Err.Description, Err.Number + Err.Clear + End If + On Error GoTo 0 + End Sub + + ' Centralized error handling for dispatch errors + Private Sub HandleDispatchError(actionName, errorDesc, errorNum) + Dim isDevelopment + isDevelopment = (LCase(GetAppSetting("Environment")) = "development") + + If isDevelopment Then + Response.Write "
" + Response.Write "Controller Action Error
" + Response.Write "Action: " & Server.HTMLEncode(actionName) & "
" + Response.Write "Error: " & Server.HTMLEncode(errorDesc) & "
" + Response.Write "Error Number: " & errorNum + Response.Write "
" + Else + Response.Write "
" + Response.Write "An error occurred
" + Response.Write "Please contact the system administrator if the problem persists." + Response.Write "
" + End If + End Sub + + Public Sub RequirePost + + If Request.Form.Count = 0 Then MVC.RedirectToExt "NotValid","",empty:End If + + End Sub + + ' Shortcut for RedirectToActionExt that does not require passing a parameters argument. + Public Sub RedirectToAction(ByVal action_name) + RedirectToActionExt action_name, empty + End Sub + + Public Sub RedirectTo(controller_name, action_name) + RedirectToExt controller_name, action_name, empty + End Sub + + ' Redirects the browser to the specified action on the specified controller with the specified querystring parameters. + ' params is a KVArray of querystring parameters. + Public Sub RedirectToExt(controller_name, action_name, params) + Response.Redirect Routes.UrlTo(controller_name, action_name, params) + End Sub + + Public Sub RedirectToActionExt(ByVal action_name, ByVal params) + RedirectToExt ControllerName, action_name, params + End Sub + +End Class +dim MVC_Dispatcher_Class__Singleton +Function MVC() + if IsEmpty(MVC_Dispatcher_Class__Singleton) then + set MVC_Dispatcher_Class__Singleton = new MVC_Dispatcher_Class + end if + set MVC = MVC_Dispatcher_Class__Singleton +End Function +%> diff --git a/core/router.wsc b/core/router.wsc new file mode 100644 index 0000000..931300e --- /dev/null +++ b/core/router.wsc @@ -0,0 +1,148 @@ + + + + + + + + + + + + + + + + + diff --git a/public/Default.asp b/public/Default.asp new file mode 100644 index 0000000..e6463b7 --- /dev/null +++ b/public/Default.asp @@ -0,0 +1,12 @@ + + +<% + ' Home page routes + router.AddRoute "GET", "/", "HomeController", "Index" + router.AddRoute "GET", "", "HomeController", "Index" + router.AddRoute "GET", "/home", "HomeController", "Index" + + ' Dispatch the request (resolves route and executes controller action) + MVC.DispatchRequest Request.ServerVariables("REQUEST_METHOD"), _ + TrimQueryParams(Request.ServerVariables("HTTP_X_ORIGINAL_URL")) +%> diff --git a/public/css/home.css b/public/css/home.css new file mode 100644 index 0000000..ae157ed --- /dev/null +++ b/public/css/home.css @@ -0,0 +1,1426 @@ +:root { + --ink: #102637; + --muted: #5d6c77; + --navy: #052f4f; + --navy-deep: #03243d; + --blue: #0b5d86; + --blue-light: #dff1f6; + --gold: #f1bf24; + --gold-dark: #c89500; + --cream: #faf6eb; + --paper: #fffdf8; + --white: #ffffff; + --coral: #ef7257; + --line: #dfe4e6; + --shadow: 0 24px 70px rgba(6, 47, 79, 0.14); + --radius-sm: 12px; + --radius-md: 22px; + --radius-lg: 34px; + --shell: 1180px; + --font-display: "Manrope", "Segoe UI", sans-serif; + --font-body: "DM Sans", "Segoe UI", sans-serif; +} + +*, +*::before, +*::after { + box-sizing: border-box; +} + +html { + scroll-behavior: smooth; +} + +body { + margin: 0; + overflow-x: clip; + background: var(--paper); + color: var(--ink); + font-family: var(--font-body); + font-size: 16px; + line-height: 1.65; + -webkit-font-smoothing: antialiased; +} + +img { + display: block; + max-width: 100%; +} + +a { + color: inherit; +} + +button, +a, +summary { + -webkit-tap-highlight-color: transparent; +} + +:focus-visible { + outline: 3px solid var(--gold); + outline-offset: 4px; +} + +.skip-link { + position: fixed; + z-index: 1000; + top: 12px; + left: 12px; + padding: 10px 16px; + border-radius: 8px; + background: var(--white); + color: var(--navy); + font-weight: 700; + transform: translateY(-150%); + transition: transform 160ms ease; +} + +.skip-link:focus { + transform: translateY(0); +} + +.shell { + width: min(var(--shell), calc(100% - 40px)); + margin-inline: auto; +} + +.site-header { + position: sticky; + z-index: 50; + top: 0; + border-bottom: 1px solid rgba(5, 47, 79, 0.1); + background: rgba(255, 253, 248, 0.94); + backdrop-filter: blur(14px); +} + +.nav-shell { + min-height: 82px; + display: grid; + grid-template-columns: minmax(180px, 235px) 1fr auto; + align-items: center; + gap: 30px; +} + +.brand { + display: block; + width: 217px; +} + +.brand img, +.footer-brand img, +.postcard-feature img { + width: auto; + max-width: none; + height: auto; +} + +.site-nav { + display: flex; + justify-content: center; + gap: clamp(18px, 2.5vw, 34px); +} + +.site-nav a, +.site-footer nav a { + position: relative; + color: #334b5c; + font-size: 0.9rem; + font-weight: 700; + text-decoration: none; +} + +.site-nav a::after, +.site-footer nav a::after { + position: absolute; + right: 0; + bottom: -7px; + left: 0; + height: 2px; + background: var(--gold-dark); + content: ""; + transform: scaleX(0); + transform-origin: left; + transition: transform 180ms ease; +} + +.site-nav a:hover::after, +.site-footer nav a:hover::after { + transform: scaleX(1); +} + +.button { + min-height: 52px; + display: inline-flex; + align-items: center; + justify-content: center; + gap: 10px; + padding: 13px 22px; + border: 1px solid transparent; + border-radius: 999px; + font-family: var(--font-display); + font-size: 0.94rem; + font-weight: 800; + line-height: 1.2; + text-align: center; + text-decoration: none; + transition: transform 180ms ease, box-shadow 180ms ease, background-color 180ms ease; +} + +.button:hover { + transform: translateY(-2px); +} + +.button-small { + min-height: 44px; + padding: 10px 18px; + font-size: 0.85rem; +} + +.button-primary { + background: var(--navy); + box-shadow: 0 10px 25px rgba(5, 47, 79, 0.2); + color: var(--white); +} + +.button-primary:hover { + background: #084368; + box-shadow: 0 14px 30px rgba(5, 47, 79, 0.25); +} + +.button-quiet { + border-color: rgba(5, 47, 79, 0.18); + background: rgba(255, 255, 255, 0.72); + color: var(--navy); +} + +.button-quiet:hover { + border-color: rgba(5, 47, 79, 0.34); + background: var(--white); +} + +.button-gold { + background: var(--gold); + box-shadow: 0 14px 30px rgba(0, 0, 0, 0.18); + color: var(--navy-deep); +} + +.button-gold:hover { + background: #ffd44a; +} + +.hero { + position: relative; + isolation: isolate; + min-height: 710px; + overflow: hidden; + background: + linear-gradient(118deg, rgba(250, 246, 235, 0.84), rgba(255, 253, 248, 0.95)), + radial-gradient(circle at 15% 20%, rgba(241, 191, 36, 0.17), transparent 34%); +} + +.hero::before { + position: absolute; + z-index: -1; + top: -35%; + right: -13%; + width: 55%; + aspect-ratio: 1; + border: 1px solid rgba(11, 93, 134, 0.08); + border-radius: 50%; + box-shadow: 0 0 0 80px rgba(11, 93, 134, 0.025), 0 0 0 160px rgba(11, 93, 134, 0.02); + content: ""; +} + +.hero-grid { + min-height: 710px; + display: grid; + grid-template-columns: minmax(0, 0.93fr) minmax(500px, 1.07fr); + align-items: center; + gap: clamp(38px, 6vw, 78px); + padding-block: 74px 80px; +} + +.hero-copy { + position: relative; + z-index: 2; +} + +.eyebrow { + margin: 0 0 20px; + color: var(--blue); + font-size: 0.76rem; + font-weight: 800; + letter-spacing: 0.14em; + text-transform: uppercase; +} + +.eyebrow span { + width: 25px; + height: 3px; + display: inline-block; + margin: 0 10px 3px 0; + border-radius: 2px; + background: var(--gold); +} + +.hero h1, +.section-heading h2, +.value-copy h2, +.offer-copy h2, +.faq-intro h2, +.cta-card h2 { + margin: 0; + color: var(--navy); + font-family: var(--font-display); + font-weight: 800; + letter-spacing: -0.045em; + line-height: 1.06; +} + +.hero h1 { + max-width: 700px; + font-size: clamp(3rem, 5.6vw, 5.3rem); +} + +.hero h1 em { + color: var(--blue); + font-style: normal; + padding-inline: 0.03em; + background: linear-gradient(transparent 83%, rgba(241, 191, 36, 0.58) 83% 94%, transparent 94%); + -webkit-box-decoration-break: clone; + box-decoration-break: clone; +} + +.hero-lede { + max-width: 640px; + margin: 26px 0 0; + color: #435967; + font-size: clamp(1.05rem, 1.5vw, 1.2rem); + line-height: 1.75; +} + +.hero-actions { + display: flex; + flex-wrap: wrap; + gap: 13px; + margin-top: 34px; +} + +.hero-points { + display: flex; + flex-wrap: wrap; + gap: 12px 22px; + margin: 29px 0 0; + padding: 0; + color: #45606f; + font-size: 0.84rem; + font-weight: 700; + list-style: none; +} + +.hero-points span { + width: 21px; + height: 21px; + display: inline-grid; + place-items: center; + margin-right: 6px; + border-radius: 50%; + background: var(--blue-light); + color: var(--blue); + font-size: 0.72rem; +} + +.postcard-stage { + position: relative; + min-height: 520px; + display: grid; + place-items: center; + perspective: 1200px; +} + +.postcard-shadow { + position: absolute; + right: 3%; + bottom: 7%; + width: 80%; + height: 19%; + border-radius: 50%; + background: rgba(6, 31, 50, 0.24); + filter: blur(30px); + transform: rotate(-4deg); +} + +.postcard { + position: relative; + width: min(100%, 610px); + aspect-ratio: 12 / 9; + overflow: hidden; + padding: clamp(15px, 2vw, 24px); + border: 1px solid rgba(5, 47, 79, 0.12); + border-radius: 18px; + background: #fffef9; + box-shadow: 0 34px 80px rgba(5, 47, 79, 0.22), 0 5px 15px rgba(5, 47, 79, 0.12); +} + +.postcard::after { + position: absolute; + inset: 0; + border-radius: inherit; + background: linear-gradient(120deg, rgba(255, 255, 255, 0.35), transparent 25% 78%, rgba(5, 47, 79, 0.04)); + content: ""; + pointer-events: none; +} + +.postcard-topline { + display: flex; + justify-content: space-between; + margin-bottom: 10px; + color: #60717d; + font-size: clamp(0.52rem, 0.8vw, 0.68rem); + font-weight: 800; + letter-spacing: 0.14em; +} + +.postcard-feature { + min-height: 30%; + display: grid; + grid-template-columns: 187px 1fr; + align-items: center; + gap: 14px; + padding: 10px 18px 13px; + border-radius: 12px; + background: linear-gradient(115deg, #f8edc8, #fff6d8 58%, #f8e8a7); +} + +.postcard-feature strong { + color: var(--navy); + font-family: var(--font-display); + font-size: clamp(0.8rem, 1.6vw, 1.3rem); + line-height: 1.18; + text-align: right; +} + +.ad-grid { + height: 49%; + display: grid; + grid-template-columns: repeat(3, 1fr); + grid-template-rows: repeat(2, 1fr); + gap: 8px; + margin-top: 8px; +} + +.ad-tile { + min-width: 0; + display: flex; + flex-direction: column; + justify-content: center; + padding: clamp(8px, 1.4vw, 15px); + border: 1px solid rgba(5, 47, 79, 0.11); + border-radius: 9px; + line-height: 1.18; +} + +.ad-tile span { + margin-bottom: 5px; + font-size: clamp(0.42rem, 0.65vw, 0.59rem); + font-weight: 800; + letter-spacing: 0.1em; +} + +.ad-tile strong { + font-family: var(--font-display); + font-size: clamp(0.64rem, 1vw, 0.9rem); +} + +.tile-gold { background: #f5cf53; color: var(--navy-deep); } +.tile-navy { background: var(--navy); color: var(--white); } +.tile-cream { background: #f5f0df; color: var(--navy); } +.tile-coral { background: #f38b73; color: #3c1b13; } +.tile-blue { background: #d5edf3; color: var(--navy); } +.tile-white { border: 2px dashed var(--gold-dark); background: var(--white); color: var(--navy); text-align: center; } + +.postcard-edge { + margin-top: 8px; + color: #6a7881; + font-size: clamp(0.45rem, 0.75vw, 0.62rem); + font-weight: 700; + letter-spacing: 0.09em; + text-align: center; + text-transform: uppercase; +} + +.stage-note { + position: absolute; + right: 0; + bottom: 3px; + max-width: 315px; + display: flex; + align-items: center; + gap: 12px; + padding: 13px 17px; + border: 1px solid rgba(5, 47, 79, 0.1); + border-radius: 13px; + background: rgba(255, 255, 255, 0.95); + box-shadow: 0 12px 34px rgba(5, 47, 79, 0.14); + color: #3e5461; + font-size: 0.77rem; + font-weight: 700; + line-height: 1.35; +} + +.stage-note span { + flex: 0 0 auto; + width: 30px; + height: 30px; + display: grid; + place-items: center; + border-radius: 50%; + background: var(--gold); + color: var(--navy); + font-size: 1rem; +} + +.signal-strip { + border-block: 1px solid rgba(5, 47, 79, 0.1); + background: var(--white); +} + +.signal-grid { + display: grid; + grid-template-columns: repeat(4, 1fr); + padding-block: 28px; +} + +.signal-grid div { + min-width: 0; + padding-inline: clamp(18px, 3vw, 36px); + border-right: 1px solid var(--line); +} + +.signal-grid div:first-child { padding-left: 0; } +.signal-grid div:last-child { border-right: 0; } + +.signal-grid strong, +.signal-grid span { + display: block; +} + +.signal-grid strong { + color: var(--navy); + font-family: var(--font-display); + font-size: 1.16rem; + font-weight: 800; +} + +.signal-grid span { + margin-top: 2px; + color: var(--muted); + font-size: 0.82rem; +} + +.section { + padding-block: clamp(82px, 10vw, 130px); +} + +.section-light { background: var(--white); } +.section-warm { background: var(--cream); } + +.section-heading { + margin-bottom: 56px; +} + +.section-heading h2, +.value-copy h2, +.offer-copy h2, +.faq-intro h2, +.cta-card h2 { + font-size: clamp(2.25rem, 4.3vw, 4rem); +} + +.section-heading > p:last-child, +.heading-split > p, +.value-copy > p, +.offer-copy > p, +.faq-intro > p { + color: var(--muted); + font-size: 1.05rem; +} + +.heading-centered { + max-width: 720px; + margin-inline: auto; + text-align: center; +} + +.eyebrow-centered span { + display: none; +} + +.heading-centered > p:last-child { + max-width: 620px; + margin: 20px auto 0; +} + +.steps { + position: relative; + display: grid; + grid-template-columns: repeat(4, 1fr); + gap: 18px; + margin: 0; + padding: 0; + list-style: none; +} + +.steps::before { + position: absolute; + top: 57px; + right: 8%; + left: 8%; + height: 1px; + background: repeating-linear-gradient(90deg, var(--line) 0 8px, transparent 8px 16px); + content: ""; +} + +.steps li { + position: relative; + z-index: 1; + padding: 28px; + border: 1px solid var(--line); + border-radius: var(--radius-md); + background: var(--paper); + transition: border-color 180ms ease, transform 180ms ease, box-shadow 180ms ease; +} + +.steps li:hover { + border-color: rgba(11, 93, 134, 0.35); + box-shadow: 0 18px 45px rgba(5, 47, 79, 0.1); + transform: translateY(-5px); +} + +.step-number { + position: absolute; + top: 20px; + right: 22px; + color: #a1acb3; + font-family: var(--font-display); + font-size: 0.76rem; + font-weight: 800; +} + +.step-icon { + width: 56px; + height: 56px; + display: grid; + place-items: center; + margin-bottom: 28px; + border-radius: 16px; + background: var(--blue-light); + color: var(--blue); + font-family: var(--font-display); + font-size: 1.6rem; + font-weight: 800; +} + +.steps li:nth-child(even) .step-icon { + background: #fff0bd; + color: #886600; +} + +.steps h3, +.benefit-list h3, +.fit-card h3 { + margin: 0; + color: var(--navy); + font-family: var(--font-display); + font-size: 1.15rem; + font-weight: 800; +} + +.steps p, +.benefit-list p, +.fit-card p { + margin: 10px 0 0; + color: var(--muted); + font-size: 0.92rem; +} + +.section-navy { + position: relative; + overflow: hidden; + background: var(--navy-deep); + color: var(--white); +} + +.section-navy::before { + position: absolute; + top: -240px; + left: -190px; + width: 520px; + height: 520px; + border: 90px solid rgba(241, 191, 36, 0.055); + border-radius: 50%; + content: ""; +} + +.value-grid { + position: relative; + display: grid; + grid-template-columns: minmax(0, 0.84fr) minmax(440px, 1.16fr); + gap: clamp(60px, 9vw, 120px); +} + +.eyebrow-on-dark { color: #f9d86e; } + +.value-copy h2, +.cta-card h2 { + color: var(--white); +} + +.value-copy > p { + margin: 25px 0 0; + color: #c6d2d9; +} + +.text-link { + display: inline-flex; + gap: 10px; + margin-top: 32px; + color: #f9d86e; + font-weight: 800; + text-decoration: none; +} + +.text-link:hover span { + transform: translateX(4px); +} + +.text-link span { + transition: transform 180ms ease; +} + +.benefit-list { + display: grid; + gap: 0; +} + +.benefit-list article { + display: grid; + grid-template-columns: 48px 1fr; + gap: 22px; + padding-block: 25px; + border-bottom: 1px solid rgba(255, 255, 255, 0.14); +} + +.benefit-list article:first-child { padding-top: 0; } +.benefit-list article:last-child { padding-bottom: 0; border-bottom: 0; } + +.benefit-mark { + width: 42px; + height: 42px; + display: grid; + place-items: center; + border: 1px solid rgba(241, 191, 36, 0.42); + border-radius: 50%; + color: #f9d86e; + font-family: var(--font-display); + font-size: 0.75rem; + font-weight: 800; +} + +.benefit-list h3 { color: var(--white); } +.benefit-list p { color: #b9c8d1; } + +.heading-split { + display: grid; + grid-template-columns: minmax(0, 1.2fr) minmax(300px, 0.8fr); + align-items: end; + gap: 70px; +} + +.heading-split > p { + margin: 0 0 8px; +} + +.fit-grid { + display: grid; + grid-template-columns: repeat(4, 1fr); + gap: 16px; +} + +.fit-card { + min-height: 270px; + padding: 30px; + border: 1px solid rgba(5, 47, 79, 0.1); + border-radius: var(--radius-md); + background: rgba(255, 255, 255, 0.7); + transition: background-color 180ms ease, transform 180ms ease, box-shadow 180ms ease; +} + +.fit-card:hover { + background: var(--white); + box-shadow: 0 20px 50px rgba(5, 47, 79, 0.1); + transform: translateY(-5px); +} + +.fit-icon { + width: 64px; + height: 64px; + display: grid; + place-items: center; + margin-bottom: 40px; + border-radius: 20px; + background: var(--navy); + color: var(--gold); + font-size: 1.85rem; +} + +.offer-section { + background: var(--white); +} + +.offer-grid { + display: grid; + grid-template-columns: minmax(350px, 0.85fr) minmax(0, 1.15fr); + align-items: center; + gap: clamp(60px, 9vw, 125px); +} + +.offer-card { + position: relative; + max-width: 485px; + min-height: 520px; + overflow: hidden; + padding: clamp(34px, 5vw, 58px); + border-radius: 8px; + background: + linear-gradient(rgba(255, 255, 255, 0.03) 1px, transparent 1px), + linear-gradient(90deg, rgba(255, 255, 255, 0.03) 1px, transparent 1px), + var(--navy); + background-size: 20px 20px; + box-shadow: var(--shadow); + color: var(--white); + transform: rotate(-2.5deg); +} + +.offer-card::after { + position: absolute; + right: -90px; + bottom: -90px; + width: 260px; + height: 260px; + border: 38px solid rgba(241, 191, 36, 0.16); + border-radius: 50%; + content: ""; +} + +.offer-stamp { + position: absolute; + top: 30px; + right: 30px; + width: 82px; + height: 82px; + display: grid; + place-items: center; + border: 2px dashed var(--gold); + border-radius: 8px; + color: var(--gold); + font-family: var(--font-display); + font-size: 0.7rem; + font-weight: 800; + letter-spacing: 0.1em; + line-height: 1.2; + text-align: center; +} + +.offer-kicker { + margin: 0 0 44px; + color: #f9d86e; + font-size: 0.72rem; + font-weight: 800; + letter-spacing: 0.16em; +} + +.offer-headline { + max-width: 330px; + margin: 0; + font-family: var(--font-display); + font-size: clamp(2.2rem, 4vw, 3.5rem); + font-weight: 800; + letter-spacing: -0.045em; + line-height: 1.02; +} + +.offer-coupon { + position: relative; + z-index: 1; + display: inline-flex; + flex-direction: column; + margin-top: 46px; + padding: 16px 23px; + border-radius: 12px; + background: var(--gold); + color: var(--navy-deep); + transform: rotate(1.5deg); +} + +.offer-coupon strong { + font-family: var(--font-display); + font-size: 1.75rem; + line-height: 1; +} + +.offer-coupon span { + margin-top: 4px; + font-size: 0.75rem; + font-weight: 700; + text-transform: uppercase; +} + +.offer-url { + position: absolute; + right: 44px; + bottom: 35px; + left: 44px; + padding-top: 15px; + border-top: 1px solid rgba(255, 255, 255, 0.25); + font-size: 0.72rem; + font-weight: 800; + letter-spacing: 0.12em; +} + +.offer-copy > p { + max-width: 600px; + margin: 24px 0 0; +} + +.check-list { + display: grid; + gap: 19px; + margin: 34px 0 0; + padding: 0; + list-style: none; +} + +.check-list li { + display: grid; + grid-template-columns: 38px 1fr; + align-items: start; + gap: 15px; +} + +.check-list li > span { + width: 34px; + height: 34px; + display: grid; + place-items: center; + border-radius: 50%; + background: #e1f2ec; + color: #19714e; + font-weight: 800; +} + +.check-list strong, +.check-list small { + display: block; +} + +.check-list strong { + color: var(--navy); + font-family: var(--font-display); + font-weight: 800; +} + +.check-list small { + margin-top: 2px; + color: var(--muted); + font-size: 0.89rem; +} + +.faq-grid { + display: grid; + grid-template-columns: minmax(280px, 0.72fr) minmax(0, 1.28fr); + gap: clamp(60px, 9vw, 125px); +} + +.faq-intro { + align-self: start; + position: sticky; + top: 125px; +} + +.faq-intro > p { + margin: 24px 0 0; +} + +.faq-list { + border-top: 1px solid var(--line); +} + +.faq-list details { + border-bottom: 1px solid var(--line); +} + +.faq-list summary { + display: grid; + grid-template-columns: 1fr 32px; + align-items: center; + gap: 18px; + padding-block: 24px; + color: var(--navy); + cursor: pointer; + font-family: var(--font-display); + font-size: 1.05rem; + font-weight: 800; + list-style: none; +} + +.faq-list summary::-webkit-details-marker { + display: none; +} + +.faq-list summary span { + width: 30px; + height: 30px; + display: grid; + place-items: center; + border: 1px solid var(--line); + border-radius: 50%; + color: var(--blue); + font-size: 1.15rem; + transition: transform 180ms ease, background-color 180ms ease; +} + +.faq-list details[open] summary span { + background: var(--blue-light); + transform: rotate(45deg); +} + +.faq-list details p { + max-width: 680px; + margin: -5px 55px 25px 0; + color: var(--muted); +} + +.cta-section { + padding: 30px 0 110px; + background: var(--white); +} + +.cta-card { + position: relative; + isolation: isolate; + min-height: 365px; + display: grid; + grid-template-columns: minmax(0, 1fr) auto; + align-items: center; + gap: 55px; + overflow: hidden; + padding: clamp(45px, 7vw, 85px); + border-radius: var(--radius-lg); + background: var(--navy); + box-shadow: 0 30px 70px rgba(5, 47, 79, 0.24); + color: var(--white); +} + +.cta-card > div:not(.cta-rings) { + position: relative; + z-index: 1; +} + +.cta-card h2 { + max-width: 750px; +} + +.cta-card p:not(.eyebrow) { + max-width: 650px; + margin: 20px 0 0; + color: #c9d6dd; + font-size: 1.03rem; +} + +.cta-actions { + min-width: 245px; + display: grid; + justify-items: center; + gap: 13px; +} + +.cta-actions span { + color: #b7c8d1; + font-size: 0.75rem; +} + +.cta-rings { + position: absolute; + z-index: 0; + top: -170px; + right: -80px; + width: 520px; + height: 520px; + border: 75px solid rgba(241, 191, 36, 0.08); + border-radius: 50%; + box-shadow: 0 0 0 75px rgba(241, 191, 36, 0.035); +} + +.site-footer { + padding-block: 42px; + border-top: 1px solid var(--line); + background: var(--paper); +} + +.footer-grid { + display: grid; + grid-template-columns: 190px 1fr auto; + align-items: center; + gap: 28px; +} + +.footer-brand { + width: 187px; +} + +.site-footer p { + margin: 0; + color: var(--muted); + font-size: 0.88rem; +} + +.site-footer nav { + display: flex; + gap: 25px; +} + +.site-footer small { + grid-column: 1 / -1; + padding-top: 22px; + border-top: 1px solid var(--line); + color: #77838b; + font-size: 0.73rem; +} + +@media (max-width: 1080px) { + .nav-shell { + grid-template-columns: 217px 1fr auto; + gap: 18px; + } + + .site-nav { + gap: 16px; + } + + .site-nav a { + font-size: 0.8rem; + } + + .hero-grid { + grid-template-columns: minmax(0, 0.92fr) minmax(410px, 1.08fr); + gap: 30px; + } + + .steps, + .fit-grid { + grid-template-columns: repeat(2, 1fr); + } + + .steps::before { + display: none; + } + + .cta-card { + grid-template-columns: 1fr; + } + + .cta-actions { + justify-items: start; + } +} + +@media (max-width: 840px) { + .site-header { + position: relative; + } + + .nav-shell { + min-height: auto; + grid-template-columns: 1fr auto; + padding-block: 15px; + } + + .brand { + width: 217px; + } + + .site-nav { + grid-column: 1 / -1; + grid-row: 2; + justify-content: flex-start; + overflow-x: auto; + padding: 5px 0 2px; + scrollbar-width: none; + } + + .site-nav::-webkit-scrollbar { display: none; } + .site-nav a { white-space: nowrap; } + + .hero-grid { + grid-template-columns: 1fr; + padding-block: 65px 75px; + } + + .postcard-stage { + min-height: 475px; + } + + .postcard { + width: min(92%, 610px); + } + + .stage-note { + right: 2%; + } + + .signal-grid { + grid-template-columns: repeat(2, 1fr); + row-gap: 24px; + } + + .signal-grid div:nth-child(2) { border-right: 0; } + .signal-grid div:nth-child(3) { padding-left: 0; } + + .value-grid, + .offer-grid, + .faq-grid, + .heading-split { + grid-template-columns: 1fr; + } + + .value-grid, + .offer-grid, + .faq-grid { + gap: 62px; + } + + .heading-split { + gap: 22px; + } + + .offer-card { + justify-self: center; + width: min(100%, 485px); + } + + .faq-intro { + position: static; + } + + .footer-grid { + grid-template-columns: 1fr auto; + } + + .site-footer p { + display: none; + } +} + +@media (max-width: 600px) { + .shell { + width: min(calc(100% - 28px), var(--shell)); + } + + .nav-shell > .button { + min-height: 40px; + padding: 9px 13px; + font-size: 0.75rem; + } + + .hero { + min-height: auto; + } + + .hero-grid { + min-height: auto; + padding-block: 55px 62px; + } + + .hero h1 { + font-size: clamp(2.65rem, 13vw, 4rem); + } + + .hero-actions { + display: grid; + } + + .hero-actions .button { + width: 100%; + } + + .hero-points { + display: grid; + } + + .postcard-stage { + min-height: 365px; + } + + .postcard { + width: 100%; + padding: 12px; + border-radius: 12px; + } + + .postcard-feature { + grid-template-columns: 187px 1fr; + padding: 8px 10px; + } + + .ad-grid { + gap: 5px; + margin-top: 5px; + } + + .ad-tile { + padding: 6px; + border-radius: 5px; + } + + .stage-note { + right: 8px; + bottom: -8px; + max-width: 260px; + padding: 10px 12px; + font-size: 0.68rem; + } + + .stage-note span { + width: 25px; + height: 25px; + } + + .signal-grid { + padding-block: 23px; + } + + .signal-grid div { + padding-inline: 14px; + } + + .signal-grid strong { + font-size: 1rem; + } + + .signal-grid span { + font-size: 0.74rem; + } + + .section { + padding-block: 76px; + } + + .section-heading { + margin-bottom: 38px; + } + + .section-heading h2, + .value-copy h2, + .offer-copy h2, + .faq-intro h2, + .cta-card h2 { + font-size: clamp(2.05rem, 10vw, 3rem); + } + + .steps, + .fit-grid { + grid-template-columns: 1fr; + } + + .steps li, + .fit-card { + min-height: auto; + padding: 25px; + } + + .fit-icon { + margin-bottom: 26px; + } + + .benefit-list article { + grid-template-columns: 40px 1fr; + gap: 15px; + } + + .benefit-mark { + width: 36px; + height: 36px; + } + + .offer-card { + min-height: 450px; + padding: 35px 28px; + } + + .offer-stamp { + top: 22px; + right: 22px; + width: 70px; + height: 70px; + } + + .offer-headline { + max-width: 260px; + } + + .offer-url { + right: 28px; + left: 28px; + } + + .faq-list summary { + font-size: 0.96rem; + } + + .faq-list details p { + margin-right: 0; + } + + .cta-section { + padding-bottom: 70px; + } + + .cta-card { + min-height: auto; + gap: 35px; + padding: 42px 27px; + border-radius: 24px; + } + + .cta-actions, + .cta-actions .button { + width: 100%; + } + + .footer-grid { + grid-template-columns: 1fr; + } + + .site-footer nav { + flex-wrap: wrap; + } +} + +@media (max-width: 380px) { + .nav-shell > .button { + display: none; + } +} + +@media (prefers-reduced-motion: reduce) { + html { scroll-behavior: auto; } + + *, + *::before, + *::after { + scroll-behavior: auto !important; + transition-duration: 0.01ms !important; + } +} diff --git a/public/images/logo_sheet.png b/public/images/logo_sheet.png new file mode 100644 index 0000000..3fcbe26 Binary files /dev/null and b/public/images/logo_sheet.png differ diff --git a/public/images/logos/jpg/icon_24.jpg b/public/images/logos/jpg/icon_24.jpg new file mode 100644 index 0000000..0472a7d Binary files /dev/null and b/public/images/logos/jpg/icon_24.jpg differ diff --git a/public/images/logos/jpg/icon_256.jpg b/public/images/logos/jpg/icon_256.jpg new file mode 100644 index 0000000..e05710f Binary files /dev/null and b/public/images/logos/jpg/icon_256.jpg differ diff --git a/public/images/logos/jpg/icon_64.jpg b/public/images/logos/jpg/icon_64.jpg new file mode 100644 index 0000000..8454aae Binary files /dev/null and b/public/images/logos/jpg/icon_64.jpg differ diff --git a/public/images/logos/jpg/icon_small_8.jpg b/public/images/logos/jpg/icon_small_8.jpg new file mode 100644 index 0000000..d132f42 Binary files /dev/null and b/public/images/logos/jpg/icon_small_8.jpg differ diff --git a/public/images/logos/jpg/logo_full_large.jpg b/public/images/logos/jpg/logo_full_large.jpg new file mode 100644 index 0000000..12efed7 Binary files /dev/null and b/public/images/logos/jpg/logo_full_large.jpg differ diff --git a/public/images/logos/jpg/logo_full_medium_a.jpg b/public/images/logos/jpg/logo_full_medium_a.jpg new file mode 100644 index 0000000..fcccb6f Binary files /dev/null and b/public/images/logos/jpg/logo_full_medium_a.jpg differ diff --git a/public/images/logos/jpg/logo_full_medium_b_misprint.jpg b/public/images/logos/jpg/logo_full_medium_b_misprint.jpg new file mode 100644 index 0000000..aeae396 Binary files /dev/null and b/public/images/logos/jpg/logo_full_medium_b_misprint.jpg differ diff --git a/public/images/logos/jpg/logo_full_medium_c.jpg b/public/images/logos/jpg/logo_full_medium_c.jpg new file mode 100644 index 0000000..2ed7b88 Binary files /dev/null and b/public/images/logos/jpg/logo_full_medium_c.jpg differ diff --git a/public/images/logos/jpg/logo_full_small_a.jpg b/public/images/logos/jpg/logo_full_small_a.jpg new file mode 100644 index 0000000..b7d7c18 Binary files /dev/null and b/public/images/logos/jpg/logo_full_small_a.jpg differ diff --git a/public/images/logos/jpg/logo_full_small_b.jpg b/public/images/logos/jpg/logo_full_small_b.jpg new file mode 100644 index 0000000..f270b29 Binary files /dev/null and b/public/images/logos/jpg/logo_full_small_b.jpg differ diff --git a/public/images/logos/png/icon_24.png b/public/images/logos/png/icon_24.png new file mode 100644 index 0000000..6f5959a Binary files /dev/null and b/public/images/logos/png/icon_24.png differ diff --git a/public/images/logos/png/icon_256.png b/public/images/logos/png/icon_256.png new file mode 100644 index 0000000..9259aad Binary files /dev/null and b/public/images/logos/png/icon_256.png differ diff --git a/public/images/logos/png/icon_64.png b/public/images/logos/png/icon_64.png new file mode 100644 index 0000000..345485f Binary files /dev/null and b/public/images/logos/png/icon_64.png differ diff --git a/public/images/logos/png/icon_small_8.png b/public/images/logos/png/icon_small_8.png new file mode 100644 index 0000000..c6a74dc Binary files /dev/null and b/public/images/logos/png/icon_small_8.png differ diff --git a/public/images/logos/png/logo_full_large.png b/public/images/logos/png/logo_full_large.png new file mode 100644 index 0000000..e5353d6 Binary files /dev/null and b/public/images/logos/png/logo_full_large.png differ diff --git a/public/images/logos/png/logo_full_medium_a.png b/public/images/logos/png/logo_full_medium_a.png new file mode 100644 index 0000000..090663c Binary files /dev/null and b/public/images/logos/png/logo_full_medium_a.png differ diff --git a/public/images/logos/png/logo_full_medium_b_misprint.png b/public/images/logos/png/logo_full_medium_b_misprint.png new file mode 100644 index 0000000..912dd04 Binary files /dev/null and b/public/images/logos/png/logo_full_medium_b_misprint.png differ diff --git a/public/images/logos/png/logo_full_medium_c.png b/public/images/logos/png/logo_full_medium_c.png new file mode 100644 index 0000000..9667eaa Binary files /dev/null and b/public/images/logos/png/logo_full_medium_c.png differ diff --git a/public/images/logos/png/logo_full_small_a.png b/public/images/logos/png/logo_full_small_a.png new file mode 100644 index 0000000..09ab266 Binary files /dev/null and b/public/images/logos/png/logo_full_small_a.png differ diff --git a/public/images/logos/png/logo_full_small_b.png b/public/images/logos/png/logo_full_small_b.png new file mode 100644 index 0000000..e1b6158 Binary files /dev/null and b/public/images/logos/png/logo_full_small_b.png differ diff --git a/public/images/logos/sharp/README.md b/public/images/logos/sharp/README.md new file mode 100644 index 0000000..3a5b11f --- /dev/null +++ b/public/images/logos/sharp/README.md @@ -0,0 +1,18 @@ +# Sharp PostcardMojo Logo Set + +This directory contains recreated, sharper counterparts to the original logo +assets. The originals remain unchanged in the sibling `jpg/` and `png/` +directories. + +## Contents + +- `masters/postcardmojo-full-master.png` — high-resolution transparent wordmark +- `masters/postcardmojo-icon-master.png` — high-resolution transparent icon +- `png/` — transparent sharp assets at the original filenames and dimensions +- `jpg/` — white-background sharp assets at the original filenames and dimensions + +The `logo_full_medium_b_misprint` filename is retained for compatibility, but +the recreated image uses the correctly spelled `postcardmojo.com` wordmark. + +The production landing page uses the sharp JPG variants at their native pixel +dimensions so the browser does not resize them. diff --git a/public/images/logos/sharp/jpg/icon_24.jpg b/public/images/logos/sharp/jpg/icon_24.jpg new file mode 100644 index 0000000..1bda29a Binary files /dev/null and b/public/images/logos/sharp/jpg/icon_24.jpg differ diff --git a/public/images/logos/sharp/jpg/icon_256.jpg b/public/images/logos/sharp/jpg/icon_256.jpg new file mode 100644 index 0000000..60ca361 Binary files /dev/null and b/public/images/logos/sharp/jpg/icon_256.jpg differ diff --git a/public/images/logos/sharp/jpg/icon_64.jpg b/public/images/logos/sharp/jpg/icon_64.jpg new file mode 100644 index 0000000..e1924e6 Binary files /dev/null and b/public/images/logos/sharp/jpg/icon_64.jpg differ diff --git a/public/images/logos/sharp/jpg/icon_small_8.jpg b/public/images/logos/sharp/jpg/icon_small_8.jpg new file mode 100644 index 0000000..ae67630 Binary files /dev/null and b/public/images/logos/sharp/jpg/icon_small_8.jpg differ diff --git a/public/images/logos/sharp/jpg/logo_full_large.jpg b/public/images/logos/sharp/jpg/logo_full_large.jpg new file mode 100644 index 0000000..b76160e Binary files /dev/null and b/public/images/logos/sharp/jpg/logo_full_large.jpg differ diff --git a/public/images/logos/sharp/jpg/logo_full_medium_a.jpg b/public/images/logos/sharp/jpg/logo_full_medium_a.jpg new file mode 100644 index 0000000..a1647be Binary files /dev/null and b/public/images/logos/sharp/jpg/logo_full_medium_a.jpg differ diff --git a/public/images/logos/sharp/jpg/logo_full_medium_b_misprint.jpg b/public/images/logos/sharp/jpg/logo_full_medium_b_misprint.jpg new file mode 100644 index 0000000..9204176 Binary files /dev/null and b/public/images/logos/sharp/jpg/logo_full_medium_b_misprint.jpg differ diff --git a/public/images/logos/sharp/jpg/logo_full_medium_c.jpg b/public/images/logos/sharp/jpg/logo_full_medium_c.jpg new file mode 100644 index 0000000..221b57e Binary files /dev/null and b/public/images/logos/sharp/jpg/logo_full_medium_c.jpg differ diff --git a/public/images/logos/sharp/jpg/logo_full_small_a.jpg b/public/images/logos/sharp/jpg/logo_full_small_a.jpg new file mode 100644 index 0000000..e22ac1e Binary files /dev/null and b/public/images/logos/sharp/jpg/logo_full_small_a.jpg differ diff --git a/public/images/logos/sharp/jpg/logo_full_small_b.jpg b/public/images/logos/sharp/jpg/logo_full_small_b.jpg new file mode 100644 index 0000000..1dd502b Binary files /dev/null and b/public/images/logos/sharp/jpg/logo_full_small_b.jpg differ diff --git a/public/images/logos/sharp/masters/postcardmojo-full-master.png b/public/images/logos/sharp/masters/postcardmojo-full-master.png new file mode 100644 index 0000000..f68bac7 Binary files /dev/null and b/public/images/logos/sharp/masters/postcardmojo-full-master.png differ diff --git a/public/images/logos/sharp/masters/postcardmojo-icon-master.png b/public/images/logos/sharp/masters/postcardmojo-icon-master.png new file mode 100644 index 0000000..5a5fb75 Binary files /dev/null and b/public/images/logos/sharp/masters/postcardmojo-icon-master.png differ diff --git a/public/images/logos/sharp/png/icon_24.png b/public/images/logos/sharp/png/icon_24.png new file mode 100644 index 0000000..6d266de Binary files /dev/null and b/public/images/logos/sharp/png/icon_24.png differ diff --git a/public/images/logos/sharp/png/icon_256.png b/public/images/logos/sharp/png/icon_256.png new file mode 100644 index 0000000..277ed13 Binary files /dev/null and b/public/images/logos/sharp/png/icon_256.png differ diff --git a/public/images/logos/sharp/png/icon_64.png b/public/images/logos/sharp/png/icon_64.png new file mode 100644 index 0000000..4c10535 Binary files /dev/null and b/public/images/logos/sharp/png/icon_64.png differ diff --git a/public/images/logos/sharp/png/icon_small_8.png b/public/images/logos/sharp/png/icon_small_8.png new file mode 100644 index 0000000..cf423dd Binary files /dev/null and b/public/images/logos/sharp/png/icon_small_8.png differ diff --git a/public/images/logos/sharp/png/logo_full_large.png b/public/images/logos/sharp/png/logo_full_large.png new file mode 100644 index 0000000..9c0f23f Binary files /dev/null and b/public/images/logos/sharp/png/logo_full_large.png differ diff --git a/public/images/logos/sharp/png/logo_full_medium_a.png b/public/images/logos/sharp/png/logo_full_medium_a.png new file mode 100644 index 0000000..018190c Binary files /dev/null and b/public/images/logos/sharp/png/logo_full_medium_a.png differ diff --git a/public/images/logos/sharp/png/logo_full_medium_b_misprint.png b/public/images/logos/sharp/png/logo_full_medium_b_misprint.png new file mode 100644 index 0000000..29a122d Binary files /dev/null and b/public/images/logos/sharp/png/logo_full_medium_b_misprint.png differ diff --git a/public/images/logos/sharp/png/logo_full_medium_c.png b/public/images/logos/sharp/png/logo_full_medium_c.png new file mode 100644 index 0000000..e31a134 Binary files /dev/null and b/public/images/logos/sharp/png/logo_full_medium_c.png differ diff --git a/public/images/logos/sharp/png/logo_full_small_a.png b/public/images/logos/sharp/png/logo_full_small_a.png new file mode 100644 index 0000000..1895f19 Binary files /dev/null and b/public/images/logos/sharp/png/logo_full_small_a.png differ diff --git a/public/images/logos/sharp/png/logo_full_small_b.png b/public/images/logos/sharp/png/logo_full_small_b.png new file mode 100644 index 0000000..6eab478 Binary files /dev/null and b/public/images/logos/sharp/png/logo_full_small_b.png differ diff --git a/public/web.config b/public/web.config new file mode 100644 index 0000000..a0165fc --- /dev/null +++ b/public/web.config @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/run_site.cmd b/run_site.cmd new file mode 100644 index 0000000..2f87205 --- /dev/null +++ b/run_site.cmd @@ -0,0 +1,4 @@ +@echo off +setlocal +set "ASPC_STARTER_ROOT=%~dp0" +"C:\Program Files\IIS Express\iisexpress.exe" /config:"%~dp0applicationhost.config" \ No newline at end of file diff --git a/scripts/GenerateRepo.vbs b/scripts/GenerateRepo.vbs new file mode 100644 index 0000000..258cd9c --- /dev/null +++ b/scripts/GenerateRepo.vbs @@ -0,0 +1,637 @@ +'============================================================== +' GeneratePOBOAndRepository.vbs +' +' Usage: +' cscript //nologo GeneratePOBOAndRepository.vbs /table:Orders /pk:OrderID [/cs:MyConnString] [/config:C:\path\web.config] +' +' Reads connection string from web.config , +' discovers [table] schema, and generates: +' � POBO_.asp (Classic ASP class with typed Property Lets) +' �
Repository.asp (parameterized CRUD + paging + search) +' +' Safe for Access or SQL Server connection strings. +'============================================================== + +Option Explicit + +'---------------- Args & paths ---------------- +Dim fso, args, i, arg, parts +Dim tableName, primaryKey, csKey, configPath, thisFolder + +Set fso = CreateObject("Scripting.FileSystemObject") +Set args = WScript.Arguments + +csKey = "ConnectionString" +thisFolder = fso.GetParentFolderName(WScript.ScriptFullName) +configPath = fso.GetParentFolderName(fso.GetParentFolderName(WScript.ScriptFullName)) & "\public\web.config" + +For i = 0 To args.Count - 1 + arg = args(i) + If InStr(arg, ":") > 0 Then + parts = Split(arg, ":", 2) + Select Case LCase(Replace(parts(0), "/", "")) + Case "table": tableName = parts(1) + Case "pk": primaryKey = parts(1) + Case "cs": csKey = parts(1) + Case "config": configPath = parts(1) + End Select + End If +Next + +If Len(tableName) = 0 Or Len(primaryKey) = 0 Then + WScript.Echo "Usage: cscript //nologo GeneratePOBOAndRepository.vbs /table: /pk: [/cs:] [/config:]" + WScript.Quit 1 +End If + +' Validate table name format (alphanumeric, underscore only - prevent SQL injection) +If Not IsValidIdentifier(tableName) Then + WScript.Echo "Error: Invalid table name format. Only letters, numbers, and underscores are allowed." + WScript.Quit 1 +End If + +' Validate primary key format +If Not IsValidIdentifier(primaryKey) Then + WScript.Echo "Error: Invalid primary key format. Only letters, numbers, and underscores are allowed." + WScript.Quit 1 +End If + +'---------------- Config & connection ---------------- +Dim connStr +connStr = GetAppSetting(csKey, configPath) +If connStr = "nothing" Then + WScript.Echo "Error: Key '" & csKey & "' not found in " & configPath + WScript.Quit 1 +End If + +Dim conn +Set conn = CreateObject("ADODB.Connection") +On Error Resume Next +conn.Open connStr +If Err.Number <> 0 Then + WScript.Echo "DB connection failed: " & Err.Description + WScript.Quit 1 +End If +On Error GoTo 0 + +'---------------- Discover schema (portable) ---------------- +' Strategy: +' 1) Try OpenSchema(adSchemaColumns) for rich metadata. +' 2) Fallback to "SELECT * WHERE 1=0" to at least get names/types. +Const adSchemaColumns = 4 + +Dim cols(), types(), nullable(), ordinals(), fld, idx +Dim haveSchema : haveSchema = False + +On Error Resume Next +Dim rsCols +Set rsCols = conn.OpenSchema(adSchemaColumns, Array(Empty, Empty, tableName, Empty)) +If Err.Number = 0 Then + idx = -1 + Do Until rsCols.EOF + idx = idx + 1 + ReDim Preserve cols(idx), types(idx), nullable(idx), ordinals(idx) + cols(idx) = CStr(rsCols("COLUMN_NAME")) + types(idx) = Nz(rsCols("DATA_TYPE"), 0) ' ADO type enum + nullable(idx) = LCase(CStr(Nz(rsCols("IS_NULLABLE"), "YES"))) = "yes" + ordinals(idx) = CLng(Nz(rsCols("ORDINAL_POSITION"), idx+1)) + rsCols.MoveNext + Loop + rsCols.Close : Set rsCols = Nothing + haveSchema = (idx >= 0) +Else + Err.Clear +End If +On Error GoTo 0 + +If Not haveSchema Then + ' Fallback: get names/types from zero-row select + On Error Resume Next + Dim rsProbe + Set rsProbe = conn.Execute("SELECT * FROM " & QI(tableName) & " WHERE 1=0") + If Err.Number <> 0 Then + WScript.Echo "Error querying table [" & tableName & "]: " & Err.Description + conn.Close : Set conn = Nothing + WScript.Quit 1 + End If + On Error GoTo 0 + + idx = -1 + For Each fld In rsProbe.Fields + idx = idx + 1 + ReDim Preserve cols(idx), types(idx), nullable(idx), ordinals(idx) + cols(idx) = fld.Name + types(idx) = fld.Type + nullable(idx) = True ' Unknown; assume nullable + ordinals(idx) = idx + 1 + Next + rsProbe.Close : Set rsProbe = Nothing +End If + +If idx < 0 Then + WScript.Echo "No columns found for table [" & tableName & "]." + WScript.Quit 1 +End If + +' Sort metadata by ordinal (defensive) +Call ArraySortByParallel(ordinals, Array(cols, types, nullable)) + +' Validate PK exists +If Not InArrayInsensitive(cols, primaryKey) Then + WScript.Echo "Primary key '" & primaryKey & "' not found in table [" & tableName & "]." + WScript.Quit 1 +End If + +'---------------- Generate POBO_
.asp ---------------- +Dim poboOut +poboOut = BuildPOBO(cols, types, tableName, primaryKey) + +Dim poboPath, tf +poboPath = fso.BuildPath(thisFolder, "POBO_" & tableName & ".asp") +Set tf = fso.CreateTextFile(poboPath, True, False) +tf.Write poboOut +tf.Close +Set tf = Nothing +WScript.Echo "POBO class written to: " & poboPath + +'---------------- Generate
Repository.asp ---------------- +Dim repoOut +repoOut = BuildRepository(cols, tableName, primaryKey) + +Dim repoPath +repoPath = fso.BuildPath(thisFolder, tableName & "Repository.asp") +Set tf = fso.CreateTextFile(repoPath, True, False) +tf.Write repoOut +tf.Close +Set tf = Nothing +WScript.Echo "Repository written to: " & repoPath + +'---------------- Cleanup ---------------- +conn.Close : Set conn = Nothing +Set fso = Nothing + +'============================================================== +' POBO generator (your example, integrated) +'============================================================== +Function BuildPOBO(byRef colsArr, byRef typesArr, ByVal tName, ByVal pk) + Dim classDef, idxLocal, name, ftype + Dim parts() + ReDim parts(1000) ' Pre-allocate for performance + Dim partIdx : partIdx = 0 + + ' Build using array for performance (StringBuilder pattern) + parts(partIdx) = "<%" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = "' Auto-generated POBO for table [" & tName & "]" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = "' Generated on " & Now() & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = "' Generator: GenerateRepo.vbs v1.0" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = "'" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = "' Dependencies: core/helpers.asp (QuoteValue function)" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = vbCrLf & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = "Class POBO_" & tName & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " ' Public array of all property names" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " Public Properties" & vbCrLf & vbCrLf : partIdx = partIdx + 1 + + ' Private backing fields + For idxLocal = 0 To UBound(colsArr) + parts(partIdx) = " Private p" & colsArr(idxLocal) & vbCrLf : partIdx = partIdx + 1 + Next + + ' Initializer with defaults + parts(partIdx) = vbCrLf & " Private Sub Class_Initialize()" & vbCrLf : partIdx = partIdx + 1 + For idxLocal = 0 To UBound(colsArr) + Select Case typesArr(idxLocal) + Case 200,201,202,203 ' adChar, adVarChar, adVarWChar, adWChar (strings) + parts(partIdx) = " p" & colsArr(idxLocal) & " = """"" & vbCrLf : partIdx = partIdx + 1 + Case 7,133,135 ' adDate, adDBDate, adDBTimeStamp (dates) + parts(partIdx) = " p" & colsArr(idxLocal) & " = #1/1/1970#" & vbCrLf : partIdx = partIdx + 1 + Case 2,3,4,5,6,14,131 ' adSmallInt, adInteger, adSingle, adDouble, adCurrency, adDecimal, adNumeric + parts(partIdx) = " p" & colsArr(idxLocal) & " = 0" & vbCrLf : partIdx = partIdx + 1 + Case 11 ' adBoolean + parts(partIdx) = " p" & colsArr(idxLocal) & " = False" & vbCrLf : partIdx = partIdx + 1 + Case Else + parts(partIdx) = " p" & colsArr(idxLocal) & " = Null" & vbCrLf : partIdx = partIdx + 1 + End Select + Next + + parts(partIdx) = " Properties = Array(""" & Join(colsArr, """,""") & """)" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " End Sub" & vbCrLf & vbCrLf : partIdx = partIdx + 1 + + parts(partIdx) = " Public Property Get PrimaryKey()" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " PrimaryKey = """ & pk & """" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1 + + parts(partIdx) = " Public Property Get TableName()" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " TableName = """ & tName & """" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1 + + ' Get/Let with coercion + For idxLocal = 0 To UBound(colsArr) + name = colsArr(idxLocal) + ftype = typesArr(idxLocal) + + parts(partIdx) = " Public Property Get " & name & "()" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " " & name & " = p" & name & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1 + + parts(partIdx) = " Public Property Let " & name & "(val)" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " On Error Resume Next" & vbCrLf : partIdx = partIdx + 1 + + Select Case ftype + Case 200,201,202,203 ' Strings + parts(partIdx) = " p" & name & " = CStr(val)" & vbCrLf : partIdx = partIdx + 1 + Case 7 ' Dates + parts(partIdx) = " p" & name & " = CDate(val)" & vbCrLf : partIdx = partIdx + 1 + Case 133,135 ' Timestamps + parts(partIdx) = " p" & name & " = QuoteValue(val)" & vbCrLf : partIdx = partIdx + 1 + Case 11 ' Boolean + parts(partIdx) = " p" & name & " = CBool(val)" & vbCrLf : partIdx = partIdx + 1 + Case Else ' Numeric or other + parts(partIdx) = " If IsNumeric(val) Then" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " p" & name & " = CDbl(val)" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " Else" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " p" & name & " = val" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " End If" & vbCrLf : partIdx = partIdx + 1 + End Select + + parts(partIdx) = " If Err.Number <> 0 Then" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " Err.Raise Err.Number, ""POBO_" & tName & "." & name & """, ""Invalid value for " & name & ": "" & Err.Description" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " End If" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " On Error GoTo 0" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1 + Next + + parts(partIdx) = "End Class" & vbCrLf : partIdx = partIdx + 1 + parts(partIdx) = "%>" & vbCrLf : partIdx = partIdx + 1 + + ' Join array for performance + ReDim Preserve parts(partIdx - 1) + BuildPOBO = Join(parts, "") +End Function + +'============================================================== +' Repository generator (parameterized; DAL.* expected) +'============================================================== +Function BuildRepository(byRef colsArr, ByVal tName, ByVal pk) + Dim insertCols(), updateCols(), allCols(), idCol + Dim iLocal, cName + idCol = pk + + ' Copy columns (no array-to-array assignment in VBScript) + ReDim allCols(UBound(colsArr)) + For iLocal = 0 To UBound(colsArr) + allCols(iLocal) = colsArr(iLocal) + Next + + ' Insert/Update sets: exclude PK + Dim insIdx : insIdx = -1 + For Each cName In colsArr + If Not StrEqualCI(cName, idCol) Then + insIdx = insIdx + 1 + ReDim Preserve insertCols(insIdx) + insertCols(insIdx) = cName + End If + Next + + Dim updIdx : updIdx = -1 + For Each cName In colsArr + If Not StrEqualCI(cName, idCol) Then + updIdx = updIdx + 1 + ReDim Preserve updateCols(updIdx) + updateCols(updIdx) = cName + End If + Next + + Dim QTable, QPK, selectList, selectBase + QTable = QI(tName) + QPK = QI(idCol) + selectList = JoinQI(allCols, ", ") + selectBase = "Select " & selectList & " FROM " & QTable + + Dim out + out = out & "<%" & vbCrLf + out = out & "' Auto-generated Repository for table [" & tName & "]" & vbCrLf + out = out & "' Generated on " & Now() & vbCrLf + out = out & "' Generator: GenerateRepo.vbs v1.0" & vbCrLf + out = out & "'" & vbCrLf + out = out & "' Dependencies:" & vbCrLf + out = out & "' - core/lib.DAL.asp (DAL singleton for database access)" & vbCrLf + out = out & "' - core/lib.AutoMapper.asp (Automapper for object mapping)" & vbCrLf + out = out & "' - core/lib.Collections.asp (LinkedList_Class)" & vbCrLf + out = out & "' - core/lib.helpers.asp (KVUnzip, BuildOrderBy, QI, Destroy)" & vbCrLf + out = out & vbCrLf & vbCrLf + + Dim className : className = tName & "Repository_Class" + out = out & "Class " & className & vbCrLf & vbCrLf + + ' FindByID + out = out & " Public Function FindByID(id)" & vbCrLf + out = out & " Dim sql : sql = """ & selectBase & " WHERE " & QPK & " = ?""" & vbCrLf + out = out & " Dim rs : Set rs = DAL.Query(sql, Array(id))" & vbCrLf + out = out & " If rs.EOF Then" & vbCrLf + out = out & " Err.Raise 1, """ & className & """, RecordNotFoundException(""" & idCol & """, id)" & vbCrLf + out = out & " Else" & vbCrLf + out = out & " Set FindByID = Automapper.AutoMap(rs, ""POBO_" & tName & """)" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " Destroy rs" & vbCrLf + out = out & " End Function" & vbCrLf & vbCrLf + + ' GetAll -> Find + out = out & " Public Function GetAll(orderBy)" & vbCrLf + out = out & " Set GetAll = Find(Empty, orderBy)" & vbCrLf + out = out & " End Function" & vbCrLf & vbCrLf + + ' Find + out = out & " Public Function Find(where_kvarray, order_string_or_array)" & vbCrLf + out = out & " Dim sql : sql = """ & selectBase & """" & vbCrLf + out = out & " Dim where_keys, where_values, i" & vbCrLf + out = out & " If Not IsEmpty(where_kvarray) Then" & vbCrLf + out = out & " KVUnzip where_kvarray, where_keys, where_values" & vbCrLf + out = out & " If Not IsEmpty(where_keys) Then" & vbCrLf + out = out & " sql = sql & "" WHERE """ & vbCrLf + out = out & " For i = 0 To UBound(where_keys)" & vbCrLf + out = out & " If i > 0 Then sql = sql & "" AND """ & vbCrLf + out = out & " sql = sql & "" "" & QI(where_keys(i)) & "" = ?""" & vbCrLf + out = out & " Next" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " sql = sql & BuildOrderBy(order_string_or_array, """ & QPK & """)" & vbCrLf + out = out & " Dim rs : Set rs = DAL.Query(sql, where_values)" & vbCrLf + out = out & " Dim list : Set list = new LinkedList_Class" & vbCrLf + out = out & " Do Until rs.EOF" & vbCrLf + out = out & " list.Push Automapper.AutoMap(rs, ""POBO_" & tName & """)" & vbCrLf + out = out & " rs.MoveNext" & vbCrLf + out = out & " Loop" & vbCrLf + out = out & " Set Find = list" & vbCrLf + out = out & " Destroy rs" & vbCrLf + out = out & " End Function" & vbCrLf & vbCrLf + + ' FindPaged + out = out & " Public Function FindPaged(where_kvarray, order_string_or_array, per_page, page_num, ByRef page_count, ByRef record_count)" & vbCrLf + out = out & " Dim sql : sql = """ & selectBase & """" & vbCrLf + out = out & " Dim where_keys, where_values, i" & vbCrLf + out = out & " If Not IsEmpty(where_kvarray) Then" & vbCrLf + out = out & " KVUnzip where_kvarray, where_keys, where_values" & vbCrLf + out = out & " If Not IsEmpty(where_keys) Then" & vbCrLf + out = out & " sql = sql & "" WHERE """ & vbCrLf + out = out & " For i = 0 To UBound(where_keys)" & vbCrLf + out = out & " If i > 0 Then sql = sql & "" AND """ & vbCrLf + out = out & " sql = sql & "" "" & QI(where_keys(i)) & "" = ?""" & vbCrLf + out = out & " Next" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " sql = sql & BuildOrderBy(order_string_or_array, """ & QPK & """)" & vbCrLf + out = out & " Dim rs : Set rs = DAL.PagedQuery(sql, where_values, per_page, page_num)" & vbCrLf + out = out & " If Not rs.EOF Then" & vbCrLf + out = out & " rs.PageSize = per_page" & vbCrLf + out = out & " rs.AbsolutePage = page_num" & vbCrLf + out = out & " page_count = rs.PageCount" & vbCrLf + out = out & " record_count = rs.RecordCount" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " Set FindPaged = PagedList(rs, per_page)" & vbCrLf + out = out & " Destroy rs" & vbCrLf + out = out & " End Function" & vbCrLf & vbCrLf + + ' SearchTablePaged (OR col LIKE ?) + out = out & " Public Function SearchTablePaged(columns_array, search_value, order_string_or_array, per_page, page_num, ByRef page_count, ByRef record_count)" & vbCrLf + out = out & " Dim sql : sql = """ & selectBase & """" & vbCrLf + out = out & " Dim i, params()" & vbCrLf + out = out & " If IsArray(columns_array) And UBound(columns_array) >= 0 Then" & vbCrLf + out = out & " sql = sql & "" WHERE """ & vbCrLf + out = out & " ReDim params(UBound(columns_array))" & vbCrLf + out = out & " For i = 0 To UBound(columns_array)" & vbCrLf + out = out & " If i > 0 Then sql = sql & "" OR """ & vbCrLf + out = out & " sql = sql & "" "" & QI(columns_array(i)) & "" LIKE ?""" & vbCrLf + out = out & " params(i) = ""%"" & search_value & ""%""" & vbCrLf + out = out & " Next" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " sql = sql & BuildOrderBy(order_string_or_array, """ & QPK & """)" & vbCrLf + out = out & " Dim rs : Set rs = DAL.PagedQuery(sql, params, per_page, page_num)" & vbCrLf + out = out & " If Not rs.EOF Then" & vbCrLf + out = out & " rs.PageSize = per_page" & vbCrLf + out = out & " rs.AbsolutePage = page_num" & vbCrLf + out = out & " page_count = rs.PageCount" & vbCrLf + out = out & " record_count = rs.RecordCount" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " Set SearchTablePaged = PagedList(rs, per_page)" & vbCrLf + out = out & " Destroy rs" & vbCrLf + out = out & " End Function" & vbCrLf & vbCrLf + + ' PagedList helper + out = out & " Private Function PagedList(rs, per_page)" & vbCrLf + out = out & " Dim list : Set list = new LinkedList_Class" & vbCrLf + out = out & " Dim x : x = 0" & vbCrLf + out = out & " Do While (per_page <= 0 Or x < per_page) And Not rs.EOF" & vbCrLf + out = out & " list.Push Automapper.AutoMap(rs, ""POBO_" & tName & """)" & vbCrLf + out = out & " x = x + 1" & vbCrLf + out = out & " rs.MoveNext" & vbCrLf + out = out & " Loop" & vbCrLf + out = out & " Set PagedList = list" & vbCrLf + out = out & " End Function" & vbCrLf & vbCrLf + + ' AddNew + out = out & " Public Sub AddNew(ByRef model)" & vbCrLf + out = out & " Dim sql : sql = ""INSERT INTO " & QTable & " (" & JoinQI(insertCols, ", ") & ") VALUES (" & Placeholders(UBound(insertCols)+1) & ")""" & vbCrLf + out = out & " DAL.Execute sql, " & BuildModelParamsArray("model", insertCols) & vbCrLf + out = out & " " & vbCrLf + out = out & " ' Retrieve the newly inserted ID" & vbCrLf + out = out & " On Error Resume Next" & vbCrLf + out = out & " Dim rsId : Set rsId = DAL.Query(""SELECT @@IDENTITY AS NewID"", Empty)" & vbCrLf + out = out & " If Err.Number <> 0 Then" & vbCrLf + out = out & " ' Fallback for Access databases" & vbCrLf + out = out & " Err.Clear" & vbCrLf + out = out & " Set rsId = DAL.Query(""SELECT TOP 1 " & QPK & " FROM " & QTable & " ORDER BY " & QPK & " DESC"", Empty)" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " On Error GoTo 0" & vbCrLf + out = out & " " & vbCrLf + out = out & " If Not rsId.EOF Then" & vbCrLf + out = out & " If Not IsNull(rsId(0)) Then model." & idCol & " = rsId(0)" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " Destroy rsId" & vbCrLf + out = out & " End Sub" & vbCrLf & vbCrLf + + ' Update + out = out & " Public Sub Update(model)" & vbCrLf + out = out & " Dim sql : sql = ""UPDATE " & QTable & " SET " & JoinSetters(updateCols) & " WHERE " & QPK & " = ?""" & vbCrLf + out = out & " DAL.Execute sql, " & BuildModelParamsArrayWithPK("model", updateCols, idCol) & vbCrLf + out = out & " End Sub" & vbCrLf & vbCrLf + + ' Delete + out = out & " Public Sub Delete(id)" & vbCrLf + out = out & " Dim sql : sql = ""DELETE FROM " & QTable & " WHERE " & QPK & " = ?""" & vbCrLf + out = out & " DAL.Execute sql, Array(id)" & vbCrLf + out = out & " End Sub" & vbCrLf & vbCrLf + + ' Exceptions & helpers + out = out & " Private Function RecordNotFoundException(ByVal field_name, ByVal field_val)" & vbCrLf + out = out & " RecordNotFoundException = """ & tName & " record was not found with "" & field_name & "" = '"" & field_val & ""'.""" & vbCrLf + out = out & " End Function" & vbCrLf & vbCrLf + + out = out & " Private Function QI(name)" & vbCrLf + out = out & " QI = ""["" & Replace(CStr(name), ""]"", ""]]"") & ""]""" & vbCrLf + out = out & " End Function" & vbCrLf & vbCrLf + + out = out & " Private Function BuildOrderBy(orderArg, defaultCol)" & vbCrLf + out = out & " Dim s : s = """"" & vbCrLf + out = out & " If IsEmpty(orderArg) Or IsNull(orderArg) Or orderArg = """" Then" & vbCrLf + out = out & " s = "" ORDER BY "" & defaultCol & "" ASC""" & vbCrLf + out = out & " ElseIf IsArray(orderArg) Then" & vbCrLf + out = out & " Dim i : s = "" ORDER BY """ & vbCrLf + out = out & " For i = 0 To UBound(orderArg)" & vbCrLf + out = out & " If i > 0 Then s = s & "", """ & vbCrLf + out = out & " s = s & QI(orderArg(i))" & vbCrLf + out = out & " Next" & vbCrLf + out = out & " Else" & vbCrLf + out = out & " s = "" ORDER BY "" & QI(orderArg)" & vbCrLf + out = out & " End If" & vbCrLf + out = out & " BuildOrderBy = s" & vbCrLf + out = out & " End Function" & vbCrLf + + out = out & "End Class" & vbCrLf & vbCrLf + + out = out & "Dim " & tName & "Repository__Singleton" & vbCrLf + out = out & "Function " & tName & "Repository()" & vbCrLf + out = out & " If IsEmpty(" & tName & "Repository__Singleton) Then" & vbCrLf + out = out & " Set " & tName & "Repository__Singleton = new " & className & vbCrLf + out = out & " End If" & vbCrLf + out = out & " Set " & tName & "Repository = " & tName & "Repository__Singleton" & vbCrLf + out = out & "End Function" & vbCrLf + + out = out & "%>" & vbCrLf + + BuildRepository = out +End Function + +'============================================================== +' Helpers (generator side) +'============================================================== +Function GetAppSetting(key, configFilePath) + Dim xml, nodes, node, j, localFso + Set localFso = CreateObject("Scripting.FileSystemObject") + Set xml = CreateObject("Microsoft.XMLDOM") + If Not localFso.FileExists(configFilePath) Then + GetAppSetting = "nothing" : Exit Function + End If + xml.Async = False + xml.Load(configFilePath) + If xml.ParseError.ErrorCode <> 0 Then + GetAppSetting = "nothing" : Exit Function + End If + Set nodes = xml.selectNodes("//appSettings/add") + For j = 0 To nodes.Length - 1 + Set node = nodes.Item(j) + If node.getAttribute("key") = key Then + GetAppSetting = node.getAttribute("value") + Exit Function + End If + Next + GetAppSetting = "nothing" +End Function + +Function Nz(val, defaultVal) + If IsNull(val) Or IsEmpty(val) Then + Nz = defaultVal + Else + Nz = val + End If +End Function + +Sub ArraySortByParallel(keys, arrs) + Dim iLocal, jLocal, kLocal, tmpKey, tmp + For iLocal = 0 To UBound(keys) - 1 + For jLocal = iLocal + 1 To UBound(keys) + If keys(jLocal) < keys(iLocal) Then + tmpKey = keys(iLocal) : keys(iLocal) = keys(jLocal) : keys(jLocal) = tmpKey + For kLocal = 0 To UBound(arrs) + tmp = arrs(kLocal)(iLocal) + arrs(kLocal)(iLocal) = arrs(kLocal)(jLocal) + arrs(kLocal)(jLocal) = tmp + Next + End If + Next + Next +End Sub + +Function InArrayInsensitive(a, val) + Dim z + InArrayInsensitive = False + For z = 0 To UBound(a) + If StrEqualCI(a(z), val) Then InArrayInsensitive = True : Exit Function + Next +End Function + +Function StrEqualCI(a, b) + StrEqualCI = (LCase(CStr(a)) = LCase(CStr(b))) +End Function + +Function QI(name) + QI = "[" & Replace(CStr(name), "]", "]]") & "]" +End Function + +Function JoinQI(a, sep) + Dim j, s : s = "" + For j = 0 To UBound(a) + If j > 0 Then s = s & sep + s = s & QI(a(j)) + Next + JoinQI = s +End Function + +Function Placeholders(n) + Dim j, s : s = "" + For j = 1 To n + If j > 1 Then s = s & ", " + s = s & "?" + Next + Placeholders = s +End Function + +Function JoinSetters(a) + Dim j, s : s = "" + For j = 0 To UBound(a) + If j > 0 Then s = s & ", " + s = s & QI(a(j)) & " = ?" + Next + JoinSetters = s +End Function + +Function BuildModelParamsArray(modelName, a) + Dim j, s : s = "Array(" + For j = 0 To UBound(a) + If j > 0 Then s = s & ", " + s = s & modelName & "." & a(j) + Next + s = s & ")" + BuildModelParamsArray = s +End Function + +Function BuildModelParamsArrayWithPK(modelName, a, pk) + Dim j, s : s = "Array(" + For j = 0 To UBound(a) + If j > 0 Then s = s & ", " + s = s & modelName & "." & a(j) + Next + s = s & ", " & modelName & "." & pk & ")" + BuildModelParamsArrayWithPK = s +End Function + +' Validate identifier (table name, column name, etc.) +Function IsValidIdentifier(name) + If IsEmpty(name) Or Len(name) = 0 Then + IsValidIdentifier = False + Exit Function + End If + + Dim i, ch + For i = 1 To Len(name) + ch = Mid(name, i, 1) + ' Allow a-z, A-Z, 0-9, and underscore only + If Not ((ch >= "a" And ch <= "z") Or _ + (ch >= "A" And ch <= "Z") Or _ + (ch >= "0" And ch <= "9") Or _ + ch = "_") Then + IsValidIdentifier = False + Exit Function + End If + Next + + IsValidIdentifier = True +End Function diff --git a/scripts/deploy-iis-git.ps1 b/scripts/deploy-iis-git.ps1 new file mode 100644 index 0000000..71910bd --- /dev/null +++ b/scripts/deploy-iis-git.ps1 @@ -0,0 +1,320 @@ +<# +.SYNOPSIS + Validates, packages, and deploys this repository to its dedicated IIS site. + +.DESCRIPTION + The controller packages the complete repository, computes SHA-256, transfers + the package and host installer over OpenSSH, and invokes the installer. + -LocalPreflightOnly validates source provenance, XML, package layout, and + archive safety without connecting. -PreflightOnly additionally streams the + installer to the host and runs its read-only IIS preflight without writing a + remote installer or package. +#> + +[CmdletBinding()] +param( + [ValidatePattern('^[A-Za-z0-9_. -]+$')] + [string]$SiteName = 'AspClassicUnifiedFramework', + [ValidatePattern('^[A-Za-z0-9_. -]+$')] + [string]$AppPoolName = 'AspClassicUnifiedFramework', + [string]$DeployRoot = 'D:\Deployments\AspClassicUnifiedFramework', + [string]$BindingIpAddress = '100.97.39.23', + [ValidateRange(1, 65535)] + [int]$BindingPort = 8085, + [AllowEmptyString()] + [string]$HostHeader = '', + [string]$InitialWebConfigPath = '', + [string]$RemoteTarget = 'webserver-1', + [ValidateRange(1, 65535)] + [int]$RemotePort = 22, + [string]$SourcePath = (Split-Path $PSScriptRoot -Parent), + [string]$BaseUrl = '', + [string]$ReleaseId = '', + [string]$ExpectedBranch = 'master', + [ValidateRange(2, 100)] + [int]$KeepReleases = 5, + [string]$SshExe = 'ssh', + [string]$ScpExe = 'scp', + [switch]$AllowAnyBranch, + [switch]$AllowDirty, + [switch]$RunMigrations, + [switch]$SkipSmokeTest, + [Alias('HostPreflightOnly', 'RemotePreflightOnly')] + [switch]$PreflightOnly, + [switch]$LocalPreflightOnly, + [switch]$Rollback, + [string]$RollbackTo = '', + [switch]$DryRun, + [switch]$KeepPackage +) + +Set-StrictMode -Version 2.0 +$ErrorActionPreference = 'Stop' + +function Write-Step { param([string]$Message) Write-Host ('==> ' + $Message) } + +function Assert-Command { + param([string]$Name) + if (-not (Get-Command $Name -ErrorAction SilentlyContinue)) { + throw "$Name was not found on PATH." + } +} + +function ConvertTo-SingleQuotedPowerShell { + param([string]$Value) + return "'" + $Value.Replace("'", "''") + "'" +} + +function Add-RemoteArgument { + param( + [System.Collections.Generic.List[string]]$Arguments, + [string]$Name, + [string]$Value + ) + $Arguments.Add($Name) + $Arguments.Add((ConvertTo-SingleQuotedPowerShell $Value)) +} + +function Assert-SafeNameValue { + param([string]$Name, [string]$Value) + if ([string]::IsNullOrWhiteSpace($Value) -or $Value -notmatch '^[A-Za-z0-9_. -]+$') { + throw "$Name contains unsupported characters." + } + if ($Value -match '(?i)schedulicious') { + throw "$Name must not identify a Schedulicious resource." + } +} + +function Assert-SafeDeploymentValues { + Assert-SafeNameValue -Name 'SiteName' -Value $SiteName + Assert-SafeNameValue -Name 'AppPoolName' -Value $AppPoolName + if ($DeployRoot -match '(?i)schedulicious') { + throw 'DeployRoot must not reference Schedulicious.' + } + if ([string]::IsNullOrWhiteSpace($BindingIpAddress)) { + throw 'BindingIpAddress must not be empty.' + } + $parsedAddress = $null + if (-not [System.Net.IPAddress]::TryParse($BindingIpAddress, [ref]$parsedAddress)) { + throw "BindingIpAddress is not a valid IP address: $BindingIpAddress" + } + if ($HostHeader -match '[:/\\]') { + throw 'HostHeader must be empty or a DNS host name without a scheme, port, slash, or backslash.' + } + if ($HostHeader -match '(?i)schedulicious') { + throw 'HostHeader must not reference Schedulicious.' + } +} + +function Copy-ReleaseSource { + param([string]$From, [string]$To) + + $excludedNames = @('.git', '.deployment', 'releases') + $packageRoots = @(Get-ChildItem -LiteralPath $From -Force | Where-Object { $excludedNames -notcontains $_.Name }) + $unsafeSourceItem = $packageRoots | + ForEach-Object { + if (($_.Attributes -band [IO.FileAttributes]::ReparsePoint) -ne 0) { $_ } + elseif ($_.PSIsContainer) { Get-ChildItem -LiteralPath $_.FullName -Recurse -Force } + } | + Where-Object { ($_.Attributes -band [IO.FileAttributes]::ReparsePoint) -ne 0 } | + Select-Object -First 1 + if ($null -ne $unsafeSourceItem) { + throw "Source contains a reparse point/symbolic link, which is not package-safe: $($unsafeSourceItem.FullName)" + } + + New-Item -ItemType Directory -Force -Path $To | Out-Null + $packageRoots | ForEach-Object { + if ($excludedNames -contains $_.Name) { return } + if (($_.Attributes -band [IO.FileAttributes]::ReparsePoint) -ne 0) { + throw "Source contains a reparse point/symbolic link, which is not package-safe: $($_.FullName)" + } + Copy-Item -LiteralPath $_.FullName -Destination $To -Recurse -Force + } + + $unsafeEntry = Get-ChildItem -LiteralPath $To -Recurse -Force | + Where-Object { ($_.Attributes -band [IO.FileAttributes]::ReparsePoint) -ne 0 } | + Select-Object -First 1 + if ($null -ne $unsafeEntry) { + throw "Package staging contains a reparse point/symbolic link: $($unsafeEntry.FullName)" + } +} + +function Assert-ReleaseLayout { + param([string]$Root) + $required = @( + 'public\Default.asp', + 'public\web.config', + 'core\autoload_core.asp', + 'app\controllers\autoload_controllers.asp', + 'scripts\install-iis-release.ps1' + ) + foreach ($relativePath in $required) { + if (-not (Test-Path -LiteralPath (Join-Path $Root $relativePath) -PathType Leaf)) { + throw "Package/source tree is incomplete; missing $relativePath" + } + } + foreach ($xmlFile in Get-ChildItem -LiteralPath $Root -Recurse -Force -Filter 'web.config') { + try { + [xml](Get-Content -LiteralPath $xmlFile.FullName -Raw) | Out-Null + } catch { + throw "$($xmlFile.FullName) is not valid XML: $($_.Exception.Message)" + } + } +} + +Assert-SafeDeploymentValues +$SourcePath = [System.IO.Path]::GetFullPath($SourcePath) +$installerPath = Join-Path $PSScriptRoot 'install-iis-release.ps1' +Assert-ReleaseLayout -Root $SourcePath + +$directGitRoot = Test-Path -LiteralPath (Join-Path $SourcePath '.git') +$commit = 'nogit' +if ($directGitRoot) { + Assert-Command 'git' + $branch = (& git -C $SourcePath branch --show-current).Trim() + if ($LASTEXITCODE -ne 0) { throw 'Could not determine the Git branch.' } + if ((-not $AllowAnyBranch) -and $branch -ne $ExpectedBranch) { + throw "Refusing to deploy branch '$branch'; expected '$ExpectedBranch'." + } + $dirty = & git -C $SourcePath status --porcelain + if ($LASTEXITCODE -ne 0) { throw 'Could not inspect the Git worktree.' } + if ((-not $AllowDirty) -and $null -ne $dirty -and @($dirty).Count -gt 0) { + throw 'Refusing to deploy a dirty worktree. Use -AllowDirty only for a reviewed exception.' + } + $commit = (& git -C $SourcePath rev-parse --short=12 HEAD).Trim() + if ($LASTEXITCODE -ne 0) { throw 'Could not determine the Git commit.' } + Write-Host "Source branch: $branch" + Write-Host "Source commit: $commit" +} else { + Write-Warning 'SourcePath is not a standalone Git checkout; branch and dirty-worktree checks cannot be enforced.' + if (-not $AllowAnyBranch) { + throw 'Use a standalone checkout, or pass -AllowAnyBranch for a reviewed non-Git source tree.' + } +} + +if ([string]::IsNullOrWhiteSpace($ReleaseId)) { + $ReleaseId = (Get-Date -Format 'yyyyMMdd-HHmmss') + '-' + $commit +} +if ($ReleaseId -notmatch '^[A-Za-z0-9._-]+$') { throw 'ReleaseId contains unsupported characters.' } +if ($Rollback -and [string]::IsNullOrWhiteSpace($RollbackTo)) { throw '-Rollback requires -RollbackTo.' } +if ((-not $Rollback) -and -not [string]::IsNullOrWhiteSpace($RollbackTo)) { throw '-RollbackTo requires -Rollback.' } +if ($RunMigrations -and $Rollback) { throw '-RunMigrations is not valid during rollback.' } +if (($PreflightOnly -or $LocalPreflightOnly) -and $Rollback) { + throw 'Preflight modes cannot be combined with -Rollback.' +} +if ($PreflightOnly -and $LocalPreflightOnly) { + throw '-PreflightOnly and -LocalPreflightOnly are mutually exclusive.' +} + +$workRoot = Join-Path ([System.IO.Path]::GetTempPath()) ('asp-iis-deploy-' + [Guid]::NewGuid().ToString('N')) +$packageStage = Join-Path $workRoot 'package' +$packageExtract = Join-Path $workRoot 'verify' +$packagePath = Join-Path $workRoot ($ReleaseId + '.zip') +$remoteDirectory = 'C:\Windows\Temp\asp-iis-deploy-' + $ReleaseId +$remotePackage = $remoteDirectory + '\' + $ReleaseId + '.zip' +$remoteInstaller = $remoteDirectory + '\install-iis-release.ps1' + +try { + $sha256 = '' + if (-not $Rollback) { + Write-Step 'Staging the complete repository for packaging' + Copy-ReleaseSource -From $SourcePath -To $packageStage + Assert-ReleaseLayout -Root $packageStage + Add-Type -AssemblyName System.IO.Compression.FileSystem + [System.IO.Compression.ZipFile]::CreateFromDirectory($packageStage, $packagePath, [System.IO.Compression.CompressionLevel]::Optimal, $false) + [System.IO.Compression.ZipFile]::ExtractToDirectory($packagePath, $packageExtract) + Assert-ReleaseLayout -Root $packageExtract + $sha256 = (Get-FileHash -LiteralPath $packagePath -Algorithm SHA256).Hash + Write-Host "Package: $packagePath" + Write-Host "SHA-256: $sha256" + } + + if ($LocalPreflightOnly) { + Write-Step 'Local/controller preflight passed; no network connection or host change was made' + exit 0 + } + + $remoteArguments = New-Object 'System.Collections.Generic.List[string]' + $remoteArguments.Add('&') + $remoteArguments.Add((ConvertTo-SingleQuotedPowerShell $remoteInstaller)) + Add-RemoteArgument $remoteArguments '-SiteName' $SiteName + Add-RemoteArgument $remoteArguments '-AppPoolName' $AppPoolName + Add-RemoteArgument $remoteArguments '-DeployRoot' $DeployRoot + Add-RemoteArgument $remoteArguments '-BindingIpAddress' $BindingIpAddress + Add-RemoteArgument $remoteArguments '-BindingPort' $BindingPort.ToString() + Add-RemoteArgument $remoteArguments '-HostHeader' $HostHeader + Add-RemoteArgument $remoteArguments '-KeepReleases' $KeepReleases.ToString() + if (-not [string]::IsNullOrWhiteSpace($InitialWebConfigPath)) { Add-RemoteArgument $remoteArguments '-InitialWebConfigPath' $InitialWebConfigPath } + if (-not [string]::IsNullOrWhiteSpace($BaseUrl)) { Add-RemoteArgument $remoteArguments '-BaseUrl' $BaseUrl } + + if ($Rollback) { + Add-RemoteArgument $remoteArguments '-RollbackTo' $RollbackTo + } elseif ($PreflightOnly) { + $remoteArguments.Add('-PreflightOnly') + } else { + Add-RemoteArgument $remoteArguments '-PackagePath' $remotePackage + Add-RemoteArgument $remoteArguments '-ReleaseId' $ReleaseId + Add-RemoteArgument $remoteArguments '-ExpectedSha256' $sha256 + } + if ($RunMigrations) { $remoteArguments.Add('-RunMigrations') } + if ($SkipSmokeTest) { $remoteArguments.Add('-SkipSmokeTest') } + + $remoteScript = $remoteArguments -join ' ' + $remoteEncodedCommand = [Convert]::ToBase64String([Text.Encoding]::Unicode.GetBytes($remoteScript)) + $remoteCommand = 'powershell.exe -NoProfile -NonInteractive -ExecutionPolicy RemoteSigned -EncodedCommand ' + $remoteEncodedCommand + + if ($DryRun) { + Write-Step 'Dry-run complete; no network connection was made' + Write-Host "Would use dedicated site '$SiteName' and app pool '$AppPoolName'." + Write-Host "Would use binding ${BindingIpAddress}:$BindingPort with host header '$HostHeader'." + if ($PreflightOnly) { + Write-Host 'Would stream the installer over SSH for a read-only host preflight; no remote file would be written.' + } else { + Write-Host "Would create remote directory: $remoteDirectory" + Write-Host "Would copy installer: $installerPath" + if (-not $Rollback) { Write-Host "Would copy package: $packagePath" } + Write-Host ('Would execute host script: ' + $remoteScript) + } + exit 0 + } + + Assert-Command $SshExe + if ($PreflightOnly) { + Write-Step 'Streaming the installer for read-only host preflight' + $installerSource = Get-Content -LiteralPath $installerPath -Raw + $argumentTail = @($remoteArguments | Select-Object -Skip 2) -join ' ' + $stdinScript = "& {`r`n" + $installerSource + "`r`n} " + $argumentTail + $stdinScript | & $SshExe -p $RemotePort $RemoteTarget 'powershell.exe -NoProfile -NonInteractive -ExecutionPolicy RemoteSigned -Command -' + if ($LASTEXITCODE -ne 0) { throw "Remote preflight failed with exit code $LASTEXITCODE." } + Write-Step 'Remote host preflight completed successfully without persistent host changes' + exit 0 + } + + Assert-Command $ScpExe + Write-Step 'Creating remote temporary directory' + $mkdirScript = "New-Item -ItemType Directory -Force -Path $(ConvertTo-SingleQuotedPowerShell $remoteDirectory) | Out-Null" + $mkdirEncoded = [Convert]::ToBase64String([Text.Encoding]::Unicode.GetBytes($mkdirScript)) + & $SshExe -p $RemotePort $RemoteTarget ('powershell.exe -NoProfile -NonInteractive -EncodedCommand ' + $mkdirEncoded) + if ($LASTEXITCODE -ne 0) { throw 'Remote directory creation failed.' } + + Write-Step 'Copying the host installer' + & $ScpExe -P $RemotePort $installerPath ($RemoteTarget + ':' + $remoteDirectory.Replace('\', '/') + '/install-iis-release.ps1') + if ($LASTEXITCODE -ne 0) { throw 'Installer copy failed.' } + if (-not $Rollback) { + Write-Step 'Copying the release package' + & $ScpExe -P $RemotePort $packagePath ($RemoteTarget + ':' + $remoteDirectory.Replace('\', '/') + '/' + $ReleaseId + '.zip') + if ($LASTEXITCODE -ne 0) { throw 'Package copy failed.' } + } + + Write-Step 'Invoking the host-side installer' + & $SshExe -p $RemotePort $RemoteTarget $remoteCommand + if ($LASTEXITCODE -ne 0) { throw "Remote installer failed with exit code $LASTEXITCODE." } + Write-Step 'Remote operation completed successfully' +} finally { + if ($KeepPackage -and (Test-Path -LiteralPath $packagePath)) { + $keptPath = Join-Path (Get-Location) ([System.IO.Path]::GetFileName($packagePath)) + Copy-Item -LiteralPath $packagePath -Destination $keptPath -Force + Write-Host "Package retained at $keptPath" + } + if (Test-Path -LiteralPath $workRoot) { Remove-Item -LiteralPath $workRoot -Recurse -Force } +} diff --git a/scripts/generateController.vbs b/scripts/generateController.vbs new file mode 100644 index 0000000..91cc703 Binary files /dev/null and b/scripts/generateController.vbs differ diff --git a/scripts/generateMigration.vbs b/scripts/generateMigration.vbs new file mode 100644 index 0000000..613ed3a --- /dev/null +++ b/scripts/generateMigration.vbs @@ -0,0 +1,162 @@ +'======================================================================================================================= +' MIGRATION GENERATOR +'======================================================================================================================= +' Generates a new migration file with timestamp-based versioning. +' +' Usage: +' cscript //nologo scripts\generateMigration.vbs migration_name +' +' Example: +' cscript //nologo scripts\generateMigration.vbs create_users_table +' Creates: db/migrations/20260109153045_create_users_table.asp +' + +Option Explicit + +Dim fso, migrationName, timestamp, filename, filepath, content + +Set fso = CreateObject("Scripting.FileSystemObject") + +' Check arguments +If WScript.Arguments.Count < 1 Then + WScript.Echo "Usage: cscript //nologo scripts\generateMigration.vbs migration_name" + WScript.Echo "" + WScript.Echo "Example:" + WScript.Echo " cscript //nologo scripts\generateMigration.vbs create_users_table" + WScript.Quit 1 +End If + +migrationName = WScript.Arguments(0) + +' Validate migration name (alphanumeric and underscore only) +If Not IsValidMigrationName(migrationName) Then + WScript.Echo "Error: Migration name must contain only letters, numbers, and underscores" + WScript.Quit 1 +End If + +' Generate timestamp (YYYYMMDDHHMMSS) +timestamp = GetTimestamp() + +' Create filename +filename = timestamp & "_" & migrationName & ".asp" + +' Ensure migrations directory exists +Dim migrationsDir +migrationsDir = fso.GetParentFolderName(WScript.ScriptFullName) & "\..\db\migrations" +migrationsDir = fso.GetAbsolutePathName(migrationsDir) + +If Not fso.FolderExists(migrationsDir) Then + CreateDirectoryPath migrationsDir +End If + +filepath = migrationsDir & "\" & filename + +' Check if file already exists +If fso.FileExists(filepath) Then + WScript.Echo "Error: Migration file already exists: " & filename + WScript.Quit 1 +End If + +' Generate migration content +content = GenerateMigrationContent(migrationName) + +' Write the file +Dim file +Set file = fso.CreateTextFile(filepath, True) +file.Write content +file.Close + +WScript.Echo "Migration created: " & filename +WScript.Echo "Path: " & filepath +WScript.Echo "" +WScript.Echo "Edit the file to add your migration logic, then run:" +WScript.Echo " cscript //nologo scripts\runMigrations.vbs" + +WScript.Quit 0 + +'======================================================================================================================= +' HELPER FUNCTIONS +'======================================================================================================================= + +Function GetTimestamp() + Dim dtNow, sYear, sMonth, sDay, sHour, sMinute, sSecond + dtNow = Now() + + sYear = Year(dtNow) + sMonth = Right("0" & Month(dtNow), 2) + sDay = Right("0" & Day(dtNow), 2) + sHour = Right("0" & Hour(dtNow), 2) + sMinute = Right("0" & Minute(dtNow), 2) + sSecond = Right("0" & Second(dtNow), 2) + + GetTimestamp = sYear & sMonth & sDay & sHour & sMinute & sSecond +End Function + +Function IsValidMigrationName(name) + Dim regex + Set regex = New RegExp + regex.Pattern = "^[a-zA-Z0-9_]+$" + IsValidMigrationName = regex.Test(name) +End Function + +Function GenerateMigrationContent(name) + Dim template + + template = "<%"& vbCrLf + template = template & "'======================================================================================================================="& vbCrLf + template = template & "' MIGRATION: " & name & vbCrLf + template = template & "'======================================================================================================================="& vbCrLf + template = template & "' This migration was auto-generated. Add your migration logic below."& vbCrLf + template = template & "'"& vbCrLf + template = template & "' The migration object provides these helper methods:"& vbCrLf + template = template & "' - migration.ExecuteSQL(sql) - Execute raw SQL"& vbCrLf + template = template & "' - migration.CreateTable(name, columns) - Create a table"& vbCrLf + template = template & "' - migration.DropTable(name) - Drop a table"& vbCrLf + template = template & "' - migration.AddColumn(table, column, type) - Add a column"& vbCrLf + template = template & "' - migration.DropColumn(table, column) - Drop a column"& vbCrLf + template = template & "' - migration.CreateIndex(name, table, columns) - Create an index"& vbCrLf + template = template & "' - migration.DropIndex(name, table) - Drop an index"& vbCrLf + template = template & "'"& vbCrLf + template = template & "' For complex operations, use migration.DB to access the database directly:"& vbCrLf + template = template & "' migration.DB.Execute ""INSERT INTO users (name) VALUES (?)"", Array(""John"")"& vbCrLf + template = template & "'"& vbCrLf + template = template & ""& vbCrLf + template = template & "'-----------------------------------------------------------------------------------------------------------------------"& vbCrLf + template = template & "' UP - Apply the migration"& vbCrLf + template = template & "'-----------------------------------------------------------------------------------------------------------------------"& vbCrLf + template = template & "Sub Migration_Up(migration)"& vbCrLf + template = template & " ' Example: Create a table"& vbCrLf + template = template & " ' migration.CreateTable ""users"", ""id AUTOINCREMENT PRIMARY KEY, name VARCHAR(255) NOT NULL, email VARCHAR(255), created_at DATETIME"""& vbCrLf + template = template & " "& vbCrLf + template = template & " ' Example: Add an index"& vbCrLf + template = template & " ' migration.CreateIndex ""idx_users_email"", ""users"", ""email"""& vbCrLf + template = template & " "& vbCrLf + template = template & " ' TODO: Add your migration logic here"& vbCrLf + template = template & " "& vbCrLf + template = template & "End Sub"& vbCrLf + template = template & ""& vbCrLf + template = template & "'-----------------------------------------------------------------------------------------------------------------------"& vbCrLf + template = template & "' DOWN - Rollback the migration"& vbCrLf + template = template & "'-----------------------------------------------------------------------------------------------------------------------"& vbCrLf + template = template & "Sub Migration_Down(migration)"& vbCrLf + template = template & " ' Example: Drop the table"& vbCrLf + template = template & " ' migration.DropTable ""users"""& vbCrLf + template = template & " "& vbCrLf + template = template & " ' TODO: Add your rollback logic here (reverse the Up migration)"& vbCrLf + template = template & " "& vbCrLf + template = template & "End Sub"& vbCrLf + template = template & "%>"& vbCrLf + + GenerateMigrationContent = template +End Function + +Sub CreateDirectoryPath(path) + Dim parentPath + If Not fso.FolderExists(path) Then + parentPath = fso.GetParentFolderName(path) + If parentPath <> "" Then + CreateDirectoryPath parentPath + End If + fso.CreateFolder path + End If +End Sub diff --git a/scripts/install-iis-release.ps1 b/scripts/install-iis-release.ps1 new file mode 100644 index 0000000..77bbef9 --- /dev/null +++ b/scripts/install-iis-release.ps1 @@ -0,0 +1,476 @@ +<# +.SYNOPSIS + Installs or rolls back an immutable release in a dedicated IIS site/app pool. + +.DESCRIPTION + The complete repository is retained in each immutable release and IIS serves + only \public. The script never discovers or adopts another site. + A missing dedicated target is created only after package extraction, layout, + and XML validation succeed. Host preflight is read-only and does not require + the dedicated target to exist. +#> + +[CmdletBinding(DefaultParameterSetName = 'Deploy')] +param( + [ValidatePattern('^[A-Za-z0-9_. -]+$')] + [string]$SiteName = 'AspClassicUnifiedFramework', + [ValidatePattern('^[A-Za-z0-9_. -]+$')] + [string]$AppPoolName = 'AspClassicUnifiedFramework', + [string]$DeployRoot = 'D:\Deployments\AspClassicUnifiedFramework', + [string]$BindingIpAddress = '100.97.39.23', + [ValidateRange(1, 65535)] + [int]$BindingPort = 8085, + [AllowEmptyString()] + [string]$HostHeader = '', + [string]$InitialWebConfigPath = '', + + [Parameter(ParameterSetName = 'Deploy')] + [string]$PackagePath = '', + [Parameter(ParameterSetName = 'Deploy')] + [ValidatePattern('^[A-Za-z0-9._-]+$')] + [string]$ReleaseId = (Get-Date -Format 'yyyyMMdd-HHmmss'), + [Parameter(Mandatory = $true, ParameterSetName = 'Rollback')] + [ValidatePattern('^[A-Za-z0-9._-]+$')] + [string]$RollbackTo, + + [string]$BaseUrl = '', + [ValidateRange(2, 100)] + [int]$KeepReleases = 5, + [string]$ExpectedSha256 = '', + [switch]$RunMigrations, + [switch]$SkipSmokeTest, + [switch]$PreflightOnly, + [switch]$DryRun +) + +Set-StrictMode -Version 2.0 +$ErrorActionPreference = 'Stop' + +function Write-Step { param([string]$Message) Write-Host ('==> ' + $Message) } + +function Get-NormalizedPath { + param([string]$Path) + return [System.IO.Path]::GetFullPath([Environment]::ExpandEnvironmentVariables($Path)).TrimEnd('\') +} + +function Assert-Administrator { + $identity = [Security.Principal.WindowsIdentity]::GetCurrent() + $principal = New-Object Security.Principal.WindowsPrincipal($identity) + if (-not $principal.IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { + throw 'An elevated Administrator PowerShell session is required.' + } +} + +function Assert-SafeNameValue { + param([string]$Name, [string]$Value) + if ([string]::IsNullOrWhiteSpace($Value) -or $Value -notmatch '^[A-Za-z0-9_. -]+$') { + throw "$Name contains unsupported characters." + } + if ($Value -match '(?i)schedulicious') { + throw "$Name must not identify a Schedulicious resource." + } +} + +function Assert-DeploymentInputs { + Assert-SafeNameValue -Name 'SiteName' -Value $SiteName + Assert-SafeNameValue -Name 'AppPoolName' -Value $AppPoolName + if ($DeployRoot -match '(?i)schedulicious') { throw 'DeployRoot must not reference Schedulicious.' } + if ($HostHeader -match '(?i)schedulicious') { throw 'HostHeader must not reference Schedulicious.' } + if ($HostHeader -match '[:/\\]') { + throw 'HostHeader must be empty or a DNS host name without a scheme, port, slash, or backslash.' + } + $parsedAddress = $null + if (-not [System.Net.IPAddress]::TryParse($BindingIpAddress, [ref]$parsedAddress)) { + throw "BindingIpAddress is not a valid IP address: $BindingIpAddress" + } +} + +function Assert-ReleaseLayout { + param([string]$ReleasePath) + $required = @( + 'public\Default.asp', + 'public\web.config', + 'core\autoload_core.asp', + 'app\controllers\autoload_controllers.asp', + 'scripts\install-iis-release.ps1' + ) + foreach ($relativePath in $required) { + if (-not (Test-Path -LiteralPath (Join-Path $ReleasePath $relativePath) -PathType Leaf)) { + throw "Release is incomplete; missing $relativePath" + } + } + foreach ($xmlFile in Get-ChildItem -LiteralPath $ReleasePath -Recurse -Force -Filter 'web.config') { + try { + [xml](Get-Content -LiteralPath $xmlFile.FullName -Raw) | Out-Null + } catch { + throw "$($xmlFile.FullName) is not valid XML: $($_.Exception.Message)" + } + } +} + +function Assert-ArchiveEntries { + param([string]$ZipPath) + Add-Type -AssemblyName System.IO.Compression.FileSystem + $archive = [System.IO.Compression.ZipFile]::OpenRead($ZipPath) + try { + foreach ($entry in $archive.Entries) { + $name = $entry.FullName.Replace('/', '\') + if ([System.IO.Path]::IsPathRooted($name) -or $name -match '(^|\\)\.\.(\\|$)') { + throw "Package contains an unsafe path: $($entry.FullName)" + } + } + } finally { + $archive.Dispose() + } +} + +function Get-BindingInformation { + return $BindingIpAddress + ':' + $BindingPort + ':' + $HostHeader +} + +function Assert-HostCapabilities { + # Query IIS directly instead of Get-WindowsFeature/Get-WindowsOptionalFeature: + # those feature cmdlets can stall while collecting server-manager state. + $aspHandler = (Get-WebConfiguration -PSPath 'MACHINE/WEBROOT/APPHOST' -Filter 'system.webServer/handlers').Collection | + Where-Object { $_.path -eq '*.asp' -and $_.modules -match '(^|,)IsapiModule(,|$)' -and $_.scriptProcessor -match '(?i)asp\.dll$' } | + Select-Object -First 1 + if ($null -eq $aspHandler) { + throw 'The IIS Classic ASP handler (*.asp through asp.dll) was not found.' + } + try { + Get-WebConfigurationProperty -PSPath 'MACHINE/WEBROOT/APPHOST' -Filter 'system.webServer/asp' -Name 'enableParentPaths' -ErrorAction Stop | Out-Null + } catch { + throw "The IIS Classic ASP configuration section is unavailable: $($_.Exception.Message)" + } + if ($null -eq (Get-WebGlobalModule -Name RewriteModule -ErrorAction SilentlyContinue)) { + throw 'IIS URL Rewrite is not installed (RewriteModule was not found).' + } +} + +function Assert-DeployRoot { + param([string]$Path) + $root = [System.IO.Path]::GetPathRoot($Path) + if ([string]::IsNullOrWhiteSpace($root) -or -not (Test-Path -LiteralPath $root -PathType Container)) { + throw "The deployment drive/root is unavailable: $root" + } + if ($Path.TrimEnd('\') -eq $root.TrimEnd('\')) { throw 'DeployRoot must not be a drive root.' } + if ((Test-Path -LiteralPath $Path) -and -not (Test-Path -LiteralPath $Path -PathType Container)) { + throw "DeployRoot exists but is not a directory: $Path" + } + $ancestor = $Path + while (-not (Test-Path -LiteralPath $ancestor -PathType Container)) { + $parent = Split-Path -Parent $ancestor + if ([string]::IsNullOrWhiteSpace($parent) -or $parent -eq $ancestor) { break } + $ancestor = $parent + } + if (-not (Test-Path -LiteralPath $ancestor -PathType Container)) { + throw "No accessible ancestor exists for DeployRoot: $Path" + } + Get-Item -LiteralPath $ancestor -ErrorAction Stop | Out-Null +} + +function Test-PathUnderRoot { + param([string]$Path, [string]$Root) + $normalizedPath = Get-NormalizedPath $Path + $prefix = (Get-NormalizedPath $Root) + '\' + return $normalizedPath.StartsWith($prefix, [StringComparison]::OrdinalIgnoreCase) +} + +function Get-TargetState { + $site = Get-Website -Name $SiteName -ErrorAction SilentlyContinue + $poolExists = Test-Path -LiteralPath ('IIS:\AppPools\' + $AppPoolName) + if (($null -eq $site) -ne (-not $poolExists)) { + throw 'Dedicated target is partial: the site and app pool must either both exist or both be absent.' + } + if ($null -eq $site) { + return [pscustomobject]@{ + Exists = $false; Site = $null; PhysicalPath = ''; ParentPaths = $null + SiteState = ''; PoolState = '' + } + } + if ($site.applicationPool -ne $AppPoolName) { + throw "Existing target site uses app pool '$($site.applicationPool)', expected '$AppPoolName'. Refusing adoption." + } + $otherPoolConsumer = Get-Website | + Where-Object { $_.Name -ne $SiteName -and $_.applicationPool -eq $AppPoolName } | + Select-Object -First 1 + if ($null -ne $otherPoolConsumer) { + throw "App pool '$AppPoolName' is also used by site '$($otherPoolConsumer.Name)'. Refusing to alter a shared pool." + } + $bindings = @($site.Bindings.Collection) + $expectedBinding = Get-BindingInformation + if ($bindings.Count -ne 1 -or $bindings[0].protocol -ne 'http' -or $bindings[0].bindingInformation -ne $expectedBinding) { + throw "Existing target binding does not exactly match http/$expectedBinding. Refusing adoption or binding changes." + } + $physicalPath = Get-NormalizedPath $site.physicalPath + $releasesRoot = Join-Path $DeployRoot 'releases' + if (-not (Test-PathUnderRoot -Path $physicalPath -Root $releasesRoot) -or + -not $physicalPath.EndsWith('\public', [StringComparison]::OrdinalIgnoreCase)) { + throw "Existing target physicalPath is outside this pipeline's release public directories: $physicalPath" + } + if (-not (Test-Path -LiteralPath $physicalPath -PathType Container)) { + throw "Existing target physicalPath does not exist: $physicalPath" + } + Assert-ReleaseLayout -ReleasePath (Split-Path -Parent $physicalPath) + $parentPaths = (Get-WebConfigurationProperty -PSPath 'MACHINE/WEBROOT/APPHOST' -Location $SiteName -Filter 'system.webServer/asp' -Name 'enableParentPaths').Value + return [pscustomobject]@{ + Exists = $true; Site = $site; PhysicalPath = $physicalPath; ParentPaths = [bool]$parentPaths + SiteState = (Get-WebsiteState -Name $SiteName).Value + PoolState = (Get-WebAppPoolState -Name $AppPoolName).Value + } +} + +function Assert-NoBindingConflict { + param($TargetState) + $expectedBinding = Get-BindingInformation + foreach ($candidate in Get-Website) { + if ($TargetState.Exists -and $candidate.Name -eq $SiteName) { continue } + foreach ($binding in @($candidate.Bindings.Collection)) { + if ($binding.protocol -ne 'http') { continue } + if ($binding.bindingInformation -notmatch '^(.*):(\d+):(.*)$') { continue } + $candidateIp = $Matches[1] + $candidatePort = [int]$Matches[2] + $candidateHost = $Matches[3] + $ipOverlaps = ($candidateIp -eq '*' -or $candidateIp -eq '0.0.0.0' -or $candidateIp -eq $BindingIpAddress) + if ($candidatePort -eq $BindingPort -and $candidateHost -eq $HostHeader -and $ipOverlaps) { + throw "Requested binding http/$expectedBinding conflicts with existing site '$($candidate.Name)' binding '$($binding.bindingInformation)'." + } + } + } +} + +function Get-SmokeUrl { + if (-not [string]::IsNullOrWhiteSpace($BaseUrl)) { return $BaseUrl } + $hostPart = $BindingIpAddress + if ($hostPart.Contains(':')) { $hostPart = '[' + $hostPart + ']' } + return 'http://' + $hostPart + ':' + $BindingPort +} + +function Invoke-SmokeTest { + if ($SkipSmokeTest) { + Write-Step 'Smoke test skipped by explicit request' + return + } + $target = (Get-SmokeUrl).TrimEnd('/') + '/' + Write-Step ('Smoke testing ' + $target) + $headers = @{} + if (-not [string]::IsNullOrWhiteSpace($HostHeader)) { $headers['Host'] = $HostHeader } + $response = Invoke-WebRequest -UseBasicParsing -Uri $target -Headers $headers -TimeoutSec 30 + if ($response.StatusCode -lt 200 -or $response.StatusCode -ge 400) { + throw "Smoke test returned HTTP $($response.StatusCode)" + } + Write-Host ('Smoke test returned HTTP ' + $response.StatusCode) +} + +function Set-IisRelease { + param([string]$PhysicalPath) + Set-ItemProperty -Path ('IIS:\Sites\' + $SiteName) -Name physicalPath -Value $PhysicalPath + $poolState = (Get-WebAppPoolState -Name $AppPoolName).Value + if ($poolState -eq 'Started') { Restart-WebAppPool -Name $AppPoolName } + else { Start-WebAppPool -Name $AppPoolName } +} + +function Restore-ExistingTarget { + param($TargetState) + if (-not $TargetState.Exists) { return } + Set-ItemProperty -Path ('IIS:\Sites\' + $SiteName) -Name physicalPath -Value $TargetState.PhysicalPath + Set-WebConfigurationProperty -PSPath 'MACHINE/WEBROOT/APPHOST' -Location $SiteName -Filter 'system.webServer/asp' -Name 'enableParentPaths' -Value $TargetState.ParentPaths + if ($TargetState.PoolState -eq 'Started') { + if ((Get-WebAppPoolState -Name $AppPoolName).Value -eq 'Started') { Restart-WebAppPool -Name $AppPoolName } + else { Start-WebAppPool -Name $AppPoolName } + } elseif ((Get-WebAppPoolState -Name $AppPoolName).Value -eq 'Started') { + Stop-WebAppPool -Name $AppPoolName + } + if ($TargetState.SiteState -eq 'Started') { + if ((Get-WebsiteState -Name $SiteName).Value -ne 'Started') { Start-Website -Name $SiteName } + } elseif ((Get-WebsiteState -Name $SiteName).Value -eq 'Started') { + Stop-Website -Name $SiteName + } +} + +if ($env:OS -ne 'Windows_NT') { throw 'This script must run on Windows.' } +Assert-Administrator +Import-Module WebAdministration -ErrorAction Stop +Assert-DeploymentInputs +$DeployRoot = Get-NormalizedPath $DeployRoot +Assert-DeployRoot -Path $DeployRoot +if (-not [string]::IsNullOrWhiteSpace($InitialWebConfigPath)) { + $preflightInitialConfig = Get-NormalizedPath $InitialWebConfigPath + if (-not (Test-Path -LiteralPath $preflightInitialConfig -PathType Leaf)) { + throw "InitialWebConfigPath not found: $preflightInitialConfig" + } + try { [xml](Get-Content -LiteralPath $preflightInitialConfig -Raw) | Out-Null } + catch { throw "InitialWebConfigPath is not valid XML: $($_.Exception.Message)" } +} +Assert-HostCapabilities +$targetState = Get-TargetState +Assert-NoBindingConflict -TargetState $targetState + +Write-Step "Dedicated site: $SiteName" +Write-Host "Dedicated app pool: $AppPoolName" +Write-Host "Binding: http/$(Get-BindingInformation)" +Write-Host "Deployment root: $DeployRoot" +if ($targetState.Exists) { + Write-Host 'Target state: existing and exactly matched' +} else { + Write-Host 'Target state: absent; eligible for isolated creation after release validation' +} + +if ($PreflightOnly -or $DryRun) { + Write-Step 'Host preflight passed; no IIS or filesystem changes were made' + exit 0 +} + +$releasesRoot = Join-Path $DeployRoot 'releases' +$sharedRoot = Join-Path $DeployRoot 'shared' +$sharedConfig = Join-Path $sharedRoot 'public.web.config' +$statePath = Join-Path $DeployRoot 'deployment-state.json' + +if ($PSCmdlet.ParameterSetName -eq 'Rollback') { + if (-not $targetState.Exists) { throw 'Rollback requires the dedicated target site and app pool to exist.' } + if (-not (Test-Path -LiteralPath $sharedConfig -PathType Leaf)) { throw "Shared configuration is missing: $sharedConfig" } + $rollbackRoot = Get-NormalizedPath (Join-Path $releasesRoot $RollbackTo) + if (-not (Test-PathUnderRoot -Path $rollbackRoot -Root $releasesRoot)) { throw 'Rollback target escaped the releases directory.' } + Assert-ReleaseLayout -ReleasePath $rollbackRoot + try { [xml](Get-Content -LiteralPath $sharedConfig -Raw) | Out-Null } + catch { throw "Shared configuration is not valid XML: $($_.Exception.Message)" } + try { + Set-WebConfigurationProperty -PSPath 'MACHINE/WEBROOT/APPHOST' -Location $SiteName -Filter 'system.webServer/asp' -Name 'enableParentPaths' -Value $true + Set-IisRelease -PhysicalPath (Join-Path $rollbackRoot 'public') + Invoke-SmokeTest + [ordered]@{ + siteName = $SiteName; appPoolName = $AppPoolName; currentRelease = $RollbackTo + currentPhysicalPath = (Join-Path $rollbackRoot 'public'); previousPhysicalPath = $targetState.PhysicalPath + binding = (Get-BindingInformation); switchedAtUtc = (Get-Date).ToUniversalTime().ToString('o'); operation = 'rollback' + } | ConvertTo-Json | Set-Content -LiteralPath $statePath -Encoding UTF8 + } catch { + Write-Warning 'Rollback failed; restoring the prior dedicated target path and parent-path setting.' + Restore-ExistingTarget -TargetState $targetState + throw + } + Write-Step "Rollback complete: $RollbackTo" + exit 0 +} + +if ([string]::IsNullOrWhiteSpace($PackagePath)) { throw '-PackagePath is required for deployment.' } +$PackagePath = Get-NormalizedPath $PackagePath +if (-not (Test-Path -LiteralPath $PackagePath -PathType Leaf)) { throw "Package not found: $PackagePath" } +if ([System.IO.Path]::GetExtension($PackagePath) -ne '.zip') { throw 'PackagePath must name a .zip package.' } +if (-not [string]::IsNullOrWhiteSpace($ExpectedSha256)) { + $actualHash = (Get-FileHash -LiteralPath $PackagePath -Algorithm SHA256).Hash + if ($actualHash -ne $ExpectedSha256) { throw "Package SHA-256 mismatch. Expected $ExpectedSha256; got $actualHash" } + Write-Host ('Package SHA-256 verified: ' + $actualHash) +} +Assert-ArchiveEntries -ZipPath $PackagePath + +$releaseRoot = Join-Path $releasesRoot $ReleaseId +$stagingRoot = $releaseRoot + '.staging' +if ((Test-Path -LiteralPath $releaseRoot) -or (Test-Path -LiteralPath $stagingRoot)) { throw "Release already exists: $ReleaseId" } + +$createdSite = $false +$createdPool = $false +$createdSharedConfig = $false +$iisMutationStarted = $false +try { + New-Item -ItemType Directory -Force -Path $releasesRoot, $sharedRoot | Out-Null + New-Item -ItemType Directory -Force -Path $stagingRoot | Out-Null + Expand-Archive -LiteralPath $PackagePath -DestinationPath $stagingRoot -Force + $unsafeExtractedItem = Get-ChildItem -LiteralPath $stagingRoot -Recurse -Force | + Where-Object { ($_.Attributes -band [IO.FileAttributes]::ReparsePoint) -ne 0 } | + Select-Object -First 1 + if ($null -ne $unsafeExtractedItem) { + throw "Extracted release contains a reparse point: $($unsafeExtractedItem.FullName)" + } + Assert-ReleaseLayout -ReleasePath $stagingRoot + + if (-not (Test-Path -LiteralPath $sharedConfig -PathType Leaf)) { + $initialConfig = Join-Path $stagingRoot 'public\web.config' + if (-not [string]::IsNullOrWhiteSpace($InitialWebConfigPath)) { + $initialConfig = Get-NormalizedPath $InitialWebConfigPath + if (-not (Test-Path -LiteralPath $initialConfig -PathType Leaf)) { throw "InitialWebConfigPath not found: $initialConfig" } + } + try { [xml](Get-Content -LiteralPath $initialConfig -Raw) | Out-Null } + catch { throw "Initial web.config is not valid XML: $($_.Exception.Message)" } + Copy-Item -LiteralPath $initialConfig -Destination $sharedConfig -Force + $createdSharedConfig = $true + Write-Step "Initialized shared configuration from $initialConfig" + } + try { [xml](Get-Content -LiteralPath $sharedConfig -Raw) | Out-Null } + catch { throw "Shared configuration is not valid XML: $($_.Exception.Message)" } + Copy-Item -LiteralPath $sharedConfig -Destination (Join-Path $stagingRoot 'public\web.config') -Force + Assert-ReleaseLayout -ReleasePath $stagingRoot + + if ($RunMigrations) { + $migrationScript = Join-Path $stagingRoot 'scripts\runMigrations.vbs' + if (-not (Test-Path -LiteralPath $migrationScript -PathType Leaf)) { throw "Migration script not found: $migrationScript" } + Write-Warning 'Running migrations by explicit request; IIS rollback cannot undo data changes.' + Push-Location $stagingRoot + try { + & cscript.exe //nologo $migrationScript up + if ($LASTEXITCODE -ne 0) { throw "Migration command exited with code $LASTEXITCODE" } + } finally { Pop-Location } + } + + Move-Item -LiteralPath $stagingRoot -Destination $releaseRoot + $newPublic = Join-Path $releaseRoot 'public' + + $iisMutationStarted = $true + if (-not $targetState.Exists) { + New-WebAppPool -Name $AppPoolName | Out-Null + $createdPool = $true + Set-ItemProperty -Path ('IIS:\AppPools\' + $AppPoolName) -Name managedRuntimeVersion -Value '' + New-Website -Name $SiteName -PhysicalPath $newPublic -ApplicationPool $AppPoolName -IPAddress $BindingIpAddress -Port $BindingPort -HostHeader $HostHeader | Out-Null + $createdSite = $true + } else { + Set-IisRelease -PhysicalPath $newPublic + } + + Set-WebConfigurationProperty -PSPath 'MACHINE/WEBROOT/APPHOST' -Location $SiteName -Filter 'system.webServer/asp' -Name 'enableParentPaths' -Value $true + if (-not $targetState.Exists) { + $poolState = (Get-WebAppPoolState -Name $AppPoolName).Value + if ($poolState -ne 'Started') { Start-WebAppPool -Name $AppPoolName } + $siteState = (Get-WebsiteState -Name $SiteName).Value + if ($siteState -ne 'Started') { Start-Website -Name $SiteName } + } + Invoke-SmokeTest + + [ordered]@{ + siteName = $SiteName; appPoolName = $AppPoolName; currentRelease = $ReleaseId + currentPhysicalPath = $newPublic; previousPhysicalPath = $targetState.PhysicalPath + binding = (Get-BindingInformation); packageSha256 = (Get-FileHash -LiteralPath $PackagePath -Algorithm SHA256).Hash + switchedAtUtc = (Get-Date).ToUniversalTime().ToString('o'); migrationsRun = [bool]$RunMigrations; operation = 'deploy' + } | ConvertTo-Json | Set-Content -LiteralPath $statePath -Encoding UTF8 + + $protectedPaths = @($newPublic, $targetState.PhysicalPath) + $oldReleases = Get-ChildItem -LiteralPath $releasesRoot -Directory | + Where-Object { $_.Name -notlike '*.staging' } | + Sort-Object LastWriteTimeUtc -Descending | + Select-Object -Skip $KeepReleases + foreach ($oldRelease in $oldReleases) { + $oldPublic = Join-Path $oldRelease.FullName 'public' + if ($protectedPaths -notcontains $oldPublic) { Write-Step ('Retention candidate (not deleted): ' + $oldRelease.FullName) } + } + Write-Step "Deployment complete: $ReleaseId" +} catch { + $failure = $_ + if ($iisMutationStarted) { + if ($createdSite -and (Get-Website -Name $SiteName -ErrorAction SilentlyContinue)) { + Write-Warning "Removing site created by this invocation: $SiteName" + Remove-Website -Name $SiteName + } + if ($createdPool -and (Test-Path -LiteralPath ('IIS:\AppPools\' + $AppPoolName))) { + Write-Warning "Removing app pool created by this invocation: $AppPoolName" + Remove-WebAppPool -Name $AppPoolName + } + if ($targetState.Exists) { + Write-Warning 'Restoring the prior dedicated target state.' + Restore-ExistingTarget -TargetState $targetState + } + } + if ($createdSharedConfig -and (Test-Path -LiteralPath $sharedConfig -PathType Leaf)) { + Write-Warning 'Removing shared configuration initialized by this failed invocation.' + Remove-Item -LiteralPath $sharedConfig -Force + } + if (Test-Path -LiteralPath $stagingRoot) { Write-Warning "Incomplete staging retained for inspection: $stagingRoot" } + throw $failure +} diff --git a/scripts/runMigrations.vbs b/scripts/runMigrations.vbs new file mode 100644 index 0000000..cc25d64 --- /dev/null +++ b/scripts/runMigrations.vbs @@ -0,0 +1,614 @@ +'======================================================================================================================= +' MIGRATION RUNNER (Standalone VBScript) +'======================================================================================================================= +' Runs database migrations directly via VBScript without requiring IIS/ASP. +' +' Usage: +' cscript //nologo scripts\runMigrations.vbs [command] +' +' Commands: +' up - Apply all pending migrations (default) +' down - Rollback the last migration +' status - Show migration status +' apply - Apply a specific migration file +' rollback - Rollback a specific migration file +' +' Examples: +' cscript //nologo scripts\runMigrations.vbs +' cscript //nologo scripts\runMigrations.vbs up +' cscript //nologo scripts\runMigrations.vbs down +' cscript //nologo scripts\runMigrations.vbs status +' + +Option Explicit + +Dim fso, scriptDir, projectRoot, webConfigPath, migrationsPath +Dim connectionString, command, argument + +Set fso = CreateObject("Scripting.FileSystemObject") + +' Get paths +scriptDir = fso.GetParentFolderName(WScript.ScriptFullName) +projectRoot = fso.GetAbsolutePathName(scriptDir & "\..") +webConfigPath = projectRoot & "\public\web.config" +migrationsPath = projectRoot & "\db\migrations" + +' Parse arguments +command = "up" ' default command +If WScript.Arguments.Count > 0 Then + command = LCase(WScript.Arguments(0)) +End If + +If WScript.Arguments.Count > 1 Then + argument = WScript.Arguments(1) +End If + +' Validate command +Select Case command + Case "up", "down", "status", "apply", "rollback" + ' Valid command + Case Else + ShowUsage + WScript.Quit 1 +End Select + +' Load connection string from web.config +connectionString = GetConnectionString(webConfigPath) +If connectionString = "" Then + WScript.Echo "Error: Could not read connection string from web.config" + WScript.Quit 1 +End If + +' Execute the command +On Error Resume Next +Select Case command + Case "up" + ApplyAllPending + Case "down" + RollbackLast + Case "status" + ShowStatus + Case "apply" + If argument = "" Then + WScript.Echo "Error: No migration file specified" + WScript.Echo "Usage: cscript //nologo scripts\runMigrations.vbs apply " + WScript.Quit 1 + End If + ApplyMigration argument + Case "rollback" + If argument = "" Then + WScript.Echo "Error: No migration file specified" + WScript.Echo "Usage: cscript //nologo scripts\runMigrations.vbs rollback " + WScript.Quit 1 + End If + RollbackMigration argument +End Select + +If Err.Number <> 0 Then + WScript.Echo "" + WScript.Echo "ERROR: " & Err.Description + WScript.Echo "Number: " & Err.Number + WScript.Echo "Source: " & Err.Source + WScript.Quit 1 +End If + +WScript.Quit 0 + +'======================================================================================================================= +' MIGRATION FUNCTIONS +'======================================================================================================================= + +Sub ApplyAllPending() + WScript.Echo "==============================================================" + WScript.Echo "APPLYING PENDING MIGRATIONS" + WScript.Echo "==============================================================" + WScript.Echo "" + + EnsureSchemaMigrationsTable + + Dim pending, version, versions(), i, j, temp + Set pending = GetPendingMigrations() + + If pending.Count = 0 Then + WScript.Echo "No pending migrations." + WScript.Echo "" + WScript.Echo "==============================================================" + WScript.Echo "DONE" + WScript.Echo "==============================================================" + Exit Sub + End If + + ' Sort versions + ReDim versions(pending.Count - 1) + i = 0 + For Each version In pending.Keys + versions(i) = version + i = i + 1 + Next + + ' Simple bubble sort (string comparison works for YYYYMMDDHHMMSS format) + For i = 0 To UBound(versions) - 1 + For j = i + 1 To UBound(versions) + If versions(i) > versions(j) Then + temp = versions(i) + versions(i) = versions(j) + versions(j) = temp + End If + Next + Next + + ' Apply in order + For i = 0 To UBound(versions) + ApplyMigration pending(versions(i)) + Next + + WScript.Echo "" + WScript.Echo "==============================================================" + WScript.Echo "DONE" + WScript.Echo "==============================================================" +End Sub + +Sub RollbackLast() + WScript.Echo "==============================================================" + WScript.Echo "ROLLING BACK LAST MIGRATION" + WScript.Echo "==============================================================" + WScript.Echo "" + + EnsureSchemaMigrationsTable + + Dim applied, available, version, lastVersion, filename + Set applied = GetAppliedMigrations() + + If applied.Count = 0 Then + WScript.Echo "No migrations to rollback." + WScript.Echo "" + WScript.Echo "==============================================================" + WScript.Echo "DONE" + WScript.Echo "==============================================================" + Exit Sub + End If + + ' Find the last version (string comparison works for YYYYMMDDHHMMSS format) + lastVersion = "" + For Each version In applied.Keys + If lastVersion = "" Or version > lastVersion Then + lastVersion = version + End If + Next + + ' Find the filename + Set available = GetAvailableMigrations() + If available.Exists(lastVersion) Then + filename = available(lastVersion) + RollbackMigration filename + Else + WScript.Echo "Error: Migration file not found for version: " & lastVersion + WScript.Quit 1 + End If + + WScript.Echo "" + WScript.Echo "==============================================================" + WScript.Echo "DONE" + WScript.Echo "==============================================================" +End Sub + +Sub ShowStatus() + WScript.Echo "==============================================================" + WScript.Echo "MIGRATION STATUS" + WScript.Echo "==============================================================" + WScript.Echo "" + + EnsureSchemaMigrationsTable + + Dim applied, pending, available, version + Set applied = GetAppliedMigrations() + Set pending = GetPendingMigrations() + Set available = GetAvailableMigrations() + + WScript.Echo "Applied migrations: " & applied.Count + If applied.Count > 0 Then + For Each version In applied.Keys + If available.Exists(version) Then + WScript.Echo " [X] " & available(version) + Else + WScript.Echo " [X] " & version & " (file not found)" + End If + Next + End If + + WScript.Echo "" + WScript.Echo "Pending migrations: " & pending.Count + If pending.Count > 0 Then + For Each version In pending.Keys + WScript.Echo " [ ] " & pending(version) + Next + End If + + WScript.Echo "" + WScript.Echo "==============================================================" +End Sub + +Sub ApplyMigration(filename) + Dim version + version = GetVersionFromFilename(filename) + + If version = "" Then + Err.Raise vbObjectError + 1, "Migrator", "Invalid migration filename format: " & filename + End If + + ' Check if already applied + Dim applied + Set applied = GetAppliedMigrations() + If applied.Exists(version) Then + WScript.Echo "Migration " & version & " already applied. Skipping." + Exit Sub + End If + + WScript.Echo "Applying migration: " & filename & "..." + + ' Execute the migration + ' NOTE: Access/Jet does NOT support DDL (CREATE TABLE, etc.) inside transactions + ' So we run without transaction wrapper and rely on error checking instead + Dim conn, migrationSuccess + Set conn = GetConnection() + + On Error Resume Next + migrationSuccess = ExecuteMigrationFile(filename, "Up", conn) + + If Err.Number <> 0 Then + WScript.Echo "ERROR: Migration failed - " & Err.Description + WScript.Echo "Error Number: " & Err.Number + conn.Close + Err.Raise vbObjectError + 2, "Migrator", "Migration failed: " & Err.Description + End If + On Error GoTo 0 + + ' Check if migration had SQL errors + If Not migrationSuccess Then + WScript.Echo "" + WScript.Echo "ERROR: Migration failed due to SQL errors (see above)." + WScript.Echo "Migration NOT recorded. Please fix the migration and try again." + conn.Close + WScript.Quit 1 + End If + + ' Record the migration + On Error Resume Next + Dim cmd + Set cmd = CreateObject("ADODB.Command") + Set cmd.ActiveConnection = conn + cmd.CommandText = "INSERT INTO schema_migrations (version, applied_at) VALUES (?, ?)" + cmd.Execute , Array(version, Now()) + + If Err.Number <> 0 Then + WScript.Echo "ERROR: Failed to record migration - " & Err.Description + conn.Close + Err.Raise vbObjectError + 3, "Migrator", "Failed to record migration: " & Err.Description + End If + On Error GoTo 0 + + conn.Close + WScript.Echo "Migration " & version & " applied successfully." +End Sub + +Sub RollbackMigration(filename) + Dim version + version = GetVersionFromFilename(filename) + + If version = "" Then + Err.Raise vbObjectError + 1, "Migrator", "Invalid migration filename format: " & filename + End If + + ' Check if applied + Dim applied + Set applied = GetAppliedMigrations() + If Not applied.Exists(version) Then + WScript.Echo "Migration " & version & " not applied. Skipping." + Exit Sub + End If + + WScript.Echo "Rolling back migration: " & filename & "..." + + ' Execute the migration + ' NOTE: Access/Jet does NOT support DDL (DROP TABLE, etc.) inside transactions + Dim conn, rollbackSuccess + Set conn = GetConnection() + + On Error Resume Next + rollbackSuccess = ExecuteMigrationFile(filename, "Down", conn) + + If Err.Number <> 0 Then + WScript.Echo "ERROR: Rollback failed - " & Err.Description + WScript.Echo "Error Number: " & Err.Number + conn.Close + Err.Raise vbObjectError + 4, "Migrator", "Rollback failed: " & Err.Description + End If + On Error GoTo 0 + + ' Check if rollback had SQL errors + If Not rollbackSuccess Then + WScript.Echo "" + WScript.Echo "ERROR: Rollback failed due to SQL errors (see above)." + WScript.Echo "Migration record NOT removed. Please fix the issue manually." + conn.Close + WScript.Quit 1 + End If + + ' Remove migration record + On Error Resume Next + Dim cmd + Set cmd = CreateObject("ADODB.Command") + Set cmd.ActiveConnection = conn + cmd.CommandText = "DELETE FROM schema_migrations WHERE version = ?" + cmd.Execute , Array(version) + + If Err.Number <> 0 Then + WScript.Echo "ERROR: Failed to remove migration record - " & Err.Description + conn.Close + Err.Raise vbObjectError + 5, "Migrator", "Failed to remove migration record: " & Err.Description + End If + On Error GoTo 0 + + conn.Close + WScript.Echo "Migration " & version & " rolled back successfully." +End Sub + +'======================================================================================================================= +' HELPER FUNCTIONS +'======================================================================================================================= + +Sub ShowUsage() + WScript.Echo "Usage: cscript //nologo scripts\runMigrations.vbs [command]" + WScript.Echo "" + WScript.Echo "Commands:" + WScript.Echo " up - Apply all pending migrations (default)" + WScript.Echo " down - Rollback the last migration" + WScript.Echo " status - Show migration status" + WScript.Echo " apply - Apply a specific migration file" + WScript.Echo " rollback - Rollback a specific migration file" + WScript.Echo "" + WScript.Echo "Examples:" + WScript.Echo " cscript //nologo scripts\runMigrations.vbs" + WScript.Echo " cscript //nologo scripts\runMigrations.vbs up" + WScript.Echo " cscript //nologo scripts\runMigrations.vbs down" + WScript.Echo " cscript //nologo scripts\runMigrations.vbs status" +End Sub + +Function GetConnectionString(configPath) + If Not fso.FileExists(configPath) Then + GetConnectionString = "" + Exit Function + End If + + Dim xmlDoc, node + Set xmlDoc = CreateObject("Microsoft.XMLDOM") + xmlDoc.async = False + xmlDoc.load configPath + + Set node = xmlDoc.selectSingleNode("//appSettings/add[@key='ConnectionString']/@value") + If node Is Nothing Then + GetConnectionString = "" + Else + GetConnectionString = node.text + End If +End Function + +Function GetConnection() + Dim conn + Set conn = CreateObject("ADODB.Connection") + conn.Open connectionString + Set GetConnection = conn +End Function + +Sub EnsureSchemaMigrationsTable() + Dim conn, rs + Set conn = GetConnection() + + On Error Resume Next + Set rs = conn.Execute("SELECT TOP 1 version FROM schema_migrations") + + If Err.Number <> 0 Then + ' Table doesn't exist, create it + Err.Clear + On Error GoTo 0 + + conn.Execute "CREATE TABLE schema_migrations (" & _ + "version VARCHAR(14) PRIMARY KEY, " & _ + "applied_at DATETIME NOT NULL)" + Else + If Not rs Is Nothing Then + If Not rs.EOF Then rs.Close + End If + End If + + conn.Close + On Error GoTo 0 +End Sub + +Function GetAppliedMigrations() + Dim conn, rs, versions, version + Set conn = GetConnection() + Set versions = CreateObject("Scripting.Dictionary") + + Set rs = conn.Execute("SELECT version FROM schema_migrations ORDER BY version") + + Do While Not rs.EOF + version = Trim(rs("version")) + versions.Add version, True + rs.MoveNext + Loop + + rs.Close + conn.Close + + Set GetAppliedMigrations = versions +End Function + +Function GetAvailableMigrations() + Dim folder, files, file, migrations, version + Set migrations = CreateObject("Scripting.Dictionary") + + If Not fso.FolderExists(migrationsPath) Then + Set GetAvailableMigrations = migrations + Exit Function + End If + + Set folder = fso.GetFolder(migrationsPath) + Set files = folder.Files + + For Each file In files + If LCase(fso.GetExtensionName(file.Name)) = "asp" Then + version = GetVersionFromFilename(file.Name) + If version <> "" Then + migrations.Add version, file.Name + End If + End If + Next + + Set GetAvailableMigrations = migrations +End Function + +Function GetPendingMigrations() + Dim applied, available, pending, version + Set applied = GetAppliedMigrations() + Set available = GetAvailableMigrations() + Set pending = CreateObject("Scripting.Dictionary") + + For Each version In available.Keys + If Not applied.Exists(version) Then + pending.Add version, available(version) + End If + Next + + Set GetPendingMigrations = pending +End Function + +Function GetVersionFromFilename(filename) + Dim parts + parts = Split(filename, "_") + + If UBound(parts) >= 0 Then + Dim version + version = parts(0) + ' Validate it's a 14-digit timestamp + If Len(version) = 14 And IsNumeric(version) Then + GetVersionFromFilename = version + Exit Function + End If + End If + + GetVersionFromFilename = "" +End Function + +' Global variable to hold migration context for error checking +Dim g_migrationContext + +Function ExecuteMigrationFile(filename, direction, conn) + Dim migrationPath, fileContent, migration + migrationPath = migrationsPath & "\" & filename + + If Not fso.FileExists(migrationPath) Then + Err.Raise vbObjectError + 6, "Migrator", "Migration file not found: " & migrationPath + End If + + ' Create migration context + Set migration = New MigrationContext + Set migration.Connection = conn + Set g_migrationContext = migration ' Store globally for error checking + + ' Read and execute the migration file + Dim stream + Set stream = fso.OpenTextFile(migrationPath, 1) + fileContent = stream.ReadAll + stream.Close + + ' Remove ASP tags + fileContent = Replace(fileContent, "<%", "") + fileContent = Replace(fileContent, "%>", "") + + ' Execute the migration code + ExecuteGlobal fileContent + + ' Call the appropriate method + If direction = "Up" Then + Migration_Up migration + ElseIf direction = "Down" Then + Migration_Down migration + End If + + ' Return True if successful, False if error + ExecuteMigrationFile = Not migration.HasError +End Function + +'======================================================================================================================= +' MIGRATION CONTEXT CLASS +'======================================================================================================================= +Class MigrationContext + Public Connection + Public HasError + Public LastErrorMessage + Public LastErrorNumber + + Private Sub Class_Initialize() + HasError = False + LastErrorMessage = "" + LastErrorNumber = 0 + End Sub + + Public Sub ExecuteSQL(sql) + If HasError Then Exit Sub ' Skip if previous error occurred + + On Error Resume Next + Connection.Execute sql + If Err.Number <> 0 Then + HasError = True + LastErrorNumber = Err.Number + LastErrorMessage = "SQL Error: " & Err.Description & " (Error " & Err.Number & ")" & vbCrLf & "SQL: " & sql + WScript.Echo " ERROR executing SQL: " & Err.Description + WScript.Echo " Error Number: " & Err.Number + WScript.Echo " SQL: " & sql + Err.Clear + End If + On Error GoTo 0 + End Sub + + Public Sub CreateTable(tableName, columns) + If HasError Then Exit Sub + WScript.Echo " Creating table: " & tableName + ExecuteSQL "CREATE TABLE " & tableName & " (" & columns & ")" + End Sub + + Public Sub DropTable(tableName) + If HasError Then Exit Sub + WScript.Echo " Dropping table: " & tableName + ExecuteSQL "DROP TABLE " & tableName + End Sub + + Public Sub AddColumn(tableName, columnName, columnType) + If HasError Then Exit Sub + WScript.Echo " Adding column: " & tableName & "." & columnName + ExecuteSQL "ALTER TABLE " & tableName & " ADD COLUMN " & columnName & " " & columnType + End Sub + + Public Sub DropColumn(tableName, columnName) + If HasError Then Exit Sub + WScript.Echo " Dropping column: " & tableName & "." & columnName + ExecuteSQL "ALTER TABLE " & tableName & " DROP COLUMN " & columnName + End Sub + + Public Sub CreateIndex(indexName, tableName, columns) + If HasError Then Exit Sub + WScript.Echo " Creating index: " & indexName & " on " & tableName + ExecuteSQL "CREATE INDEX " & indexName & " ON " & tableName & " (" & columns & ")" + End Sub + + Public Sub DropIndex(indexName, tableName) + If HasError Then Exit Sub + WScript.Echo " Dropping index: " & indexName & " on " & tableName + ExecuteSQL "DROP INDEX " & indexName & " ON " & tableName + End Sub + + Public Function DB() + Set DB = Me + End Function +End Class