Selaa lähdekoodia

Initial commit: Prospecting app on the RouteKit Classic ASP starter

Business prospecting tool for a 9x12 postcard business:
- Import businesses from CSV/XLSX/XLS with column mapping and phone/email de-duplication
- Searchable, filterable, sortable business list with CSV export
- Business detail: log calls/emails/visits/mailings, follow-up dates, notes, edit,
  duplicate warning, remove/restore, previous-customer flag
- Today follow-up queue (home page), dashboard of counts, industries management
- Access (.accdb) database built by migrations; scripts for ADOX database creation and
  32-bit migration runs
- Core fixes: route parameters are no longer concatenated into executed code (mvc.asp);
  GetAntiCSRFToken returns the token on first use (lib.HTML.Security.asp)

Co-Authored-By: Claude Sonnet 5.5 <noreply@anthropic.com>
master
Daniel Covington 14 tuntia sitten
commit
94589f0584
100 muutettua tiedostoa jossa 15319 lisäystä ja 0 poistoa
  1. +19
    -0
      .gitignore
  2. +162
    -0
      AGENTS.md
  3. +1
    -0
      CLAUDE.MD
  4. +96
    -0
      README.md
  5. +185
    -0
      TESTING.md
  6. +242
    -0
      app/controllers/BusinessesController.asp
  7. +58
    -0
      app/controllers/DashboardController.asp
  8. +37
    -0
      app/controllers/ErrorController.asp
  9. +83
    -0
      app/controllers/ExportController.asp
  10. +42
    -0
      app/controllers/HomeController.asp
  11. +174
    -0
      app/controllers/ImportController.asp
  12. +128
    -0
      app/controllers/IndustriesController.asp
  13. +64
    -0
      app/controllers/TodayController.asp
  14. +17
    -0
      app/controllers/autoload_controllers.asp
  15. +75
    -0
      app/lib/lib.BusinessHelpers.asp
  16. +13
    -0
      app/lib/lib.Csrf.asp
  17. +67
    -0
      app/lib/lib.Db.asp
  18. +83
    -0
      app/lib/lib.Format.asp
  19. +304
    -0
      app/lib/lib.ImportFile.asp
  20. +211
    -0
      app/lib/lib.ImportService.asp
  21. +392
    -0
      app/repositories/BusinessRepository.asp
  22. +94
    -0
      app/repositories/IndustryRepository.asp
  23. +123
    -0
      app/repositories/StatsRepository.asp
  24. +153
    -0
      app/views/Businesses/index.asp
  25. +260
    -0
      app/views/Businesses/show.asp
  26. +192
    -0
      app/views/Dashboard/index.asp
  27. +55
    -0
      app/views/Error/NotFound.asp
  28. +85
    -0
      app/views/Home/index.asp
  29. +34
    -0
      app/views/Import/index.asp
  30. +86
    -0
      app/views/Import/map.asp
  31. +43
    -0
      app/views/Import/result.asp
  32. +86
    -0
      app/views/Industries/index.asp
  33. +77
    -0
      app/views/Today/index.asp
  34. +8
    -0
      app/views/shared/footer.asp
  35. +86
    -0
      app/views/shared/header.asp
  36. +1030
    -0
      applicationhost.config
  37. +23
    -0
      core/autoload_core.asp
  38. +127
    -0
      core/databaseConnection.asp
  39. +536
    -0
      core/helpers.asp
  40. +159
    -0
      core/lib.Automapper.asp
  41. +155
    -0
      core/lib.CDOEmail.asp
  42. +914
    -0
      core/lib.Collections.asp
  43. +116
    -0
      core/lib.ControllerRegistry.asp
  44. +29
    -0
      core/lib.DAL.asp
  45. +113
    -0
      core/lib.Data.asp
  46. +202
    -0
      core/lib.Enumerable.asp
  47. +178
    -0
      core/lib.ErrorHandler.asp
  48. +151
    -0
      core/lib.Flash.asp
  49. +79
    -0
      core/lib.FormCache.asp
  50. +78
    -0
      core/lib.HTML.Security.asp
  51. +282
    -0
      core/lib.HTML.asp
  52. +439
    -0
      core/lib.Migrations.asp
  53. +262
    -0
      core/lib.Routes.asp
  54. +73
    -0
      core/lib.Strings.asp
  55. +405
    -0
      core/lib.Upload.asp
  56. +250
    -0
      core/lib.Validations.asp
  57. +52
    -0
      core/lib.ad.auth.asp
  58. +45
    -0
      core/lib.crypto.helper.asp
  59. +115
    -0
      core/lib.helpers.asp
  60. +284
    -0
      core/lib.json.asp
  61. +178
    -0
      core/mvc.asp
  62. +147
    -0
      core/router.wsc
  63. +14
    -0
      db/migrations/20261023160001_create_industries_table.asp
  64. +13
    -0
      db/migrations/20261023160002_create_import_batches_table.asp
  65. +26
    -0
      db/migrations/20261023160003_create_businesses_table.asp
  66. +17
    -0
      db/migrations/20261023160004_create_interactions_table.asp
  67. +1543
    -0
      docs/AGENTS.md
  68. +994
    -0
      docs/CLAUDE.md
  69. BIN
      docs/Windows scripting secrets.pdf
  70. +63
    -0
      docs/api-contracts-mvc-starter.md
  71. +34
    -0
      docs/architecture-patterns.md
  72. +81
    -0
      docs/architecture.md
  73. +63
    -0
      docs/component-inventory.md
  74. +46
    -0
      docs/comprehensive-analysis-mvc-starter.md
  75. +11
    -0
      docs/critical-folders-summary.md
  76. +42
    -0
      docs/data-models-mvc-starter.md
  77. +82
    -0
      docs/deployment-configuration.md
  78. +134
    -0
      docs/deployment-guide.md
  79. +55
    -0
      docs/development-guide.md
  80. +59
    -0
      docs/development-instructions.md
  81. +46
    -0
      docs/existing-documentation-inventory.md
  82. +12
    -0
      docs/ideas.md
  83. +71
    -0
      docs/index.md
  84. +70
    -0
      docs/project-overview.md
  85. +26
    -0
      docs/project-parts.json
  86. +1
    -0
      docs/project-scan-report.json
  87. +38
    -0
      docs/project-structure.md
  88. +100
    -0
      docs/source-tree-analysis.md
  89. +26
    -0
      docs/state-management-patterns-mvc-starter.md
  90. +28
    -0
      docs/technology-stack.md
  91. +50
    -0
      docs/ui-component-inventory-mvc-starter.md
  92. +13
    -0
      docs/user-provided-context.md
  93. +42
    -0
      public/Default.asp
  94. +70
    -0
      public/web.config
  95. +4
    -0
      run_site.cmd
  96. +637
    -0
      scripts/GenerateRepo.vbs
  97. +69
    -0
      scripts/createDatabase.vbs
  98. +320
    -0
      scripts/deploy-iis-git.ps1
  99. BIN
      scripts/generateController.vbs
  100. +162
    -0
      scripts/generateMigration.vbs

+ 19
- 0
.gitignore Näytä tiedosto

@@ -0,0 +1,19 @@
/_bmad
/_bmad*
/.agents
/.github

# Business data and runtime output: never commit these.
# Recreate an empty database with scripts\createDatabase.vbs + scripts\migrate.cmd up
/db/*.accdb
/db/*.laccdb
/db/*.mdb
/db/*.ldb
/db/backups/
/uploads/
/logs/

# Editor / OS noise
Thumbs.db
.DS_Store
*.bak

+ 162
- 0
AGENTS.md Näytä tiedosto

@@ -0,0 +1,162 @@
# AGENTS.md — Classic ASP / VBScript Application Agent Instructions

## Mission and role

You are the lead architect, implementer, reviewer, and debugger for this **Classic ASP (VBScript)** web application. Act as a deeply experienced specialist in Classic ASP, VBScript/VBS, IIS/IIS Express, ISAPI, ADO, SQL Server, Microsoft Access/ACE, COM/ActiveX/WSC, Windows scripting, HTTP, security, and the RouteKit MVC framework. Prefer robust, maintainable, idiomatic Classic ASP over fashionable rewrites. Do not suggest a migration to ASP.NET, PHP, or another stack unless explicitly requested.

**Source starter framework:**
`https://onefortheroadgit.sytes.net/dcovington/asp-classic-unified-framework`

The framework's README describes it as **RouteKit Classic ASP — MVC Starter**. Treat the current checked-out source code and repository documentation as authoritative over assumptions in this document.

## Mandatory first-time project initialization

**Only perform this initialization when this application directory has not yet been initialized. Never run these steps over an existing application's code or delete its `.git` history.** Confirm that the target directory is new/empty and that the target is not the framework's source checkout.

1. Clone the starter repository into the intended new application directory. Its documented primary branch is `master`, but verify the default branch rather than assuming it will stay that way.
2. Remove the cloned repository's `.git` directory **from the new application directory only**. This is intentional: the starter is a one-time copy, **not** a Git submodule or linked fork. Do not remove `.gitignore`, source files, or any other application data. If `.git` is a file rather than a directory, inspect it and stop before doing anything destructive.
3. Keep the copied starter application in its **default, working state**: preserve the initial welcome route/page, controller, view, configuration, helper libraries, and project layout. Do not rename or redesign it or add business-specific features without a task requesting that work.
4. Copy/save this `AGENTS.md` into the **root of the new application**. Never let a clone operation overwrite custom local instructions.
5. Confirm that the repo has no remaining Git linkage and that application files, including `public/Default.asp`, are present.
6. Unless the user requests otherwise, **do not automatically run `git init`**. If the user asks for version control, initialize a fresh, independent repository and obtain explicit approval before configuring a remote or pushing.
7. Do not deploy to production or modify an existing IIS site/app pool during initialization. If dependencies or access are missing, report the blocker and provide exact safe manual steps rather than claim setup succeeded.

### Example setup — PowerShell (Windows)

Run from the *parent* directory; choose a **new** destination name:

```powershell
$AppPath = 'C:\Sites\MyClassicAspApp' # CHANGE to the intended NEW path
$RepoUrl = 'https://onefortheroadgit.sytes.net/dcovington/asp-classic-unified-framework.git'

if (Test-Path -LiteralPath $AppPath) {
throw "Destination already exists. Refusing to overwrite: $AppPath"
}

git clone $RepoUrl $AppPath
if ($LASTEXITCODE -ne 0) { throw 'Clone failed; no cleanup attempted.' }

$GitPath = Join-Path $AppPath '.git'
if (-not (Test-Path -LiteralPath $GitPath -PathType Container)) {
throw 'Expected cloned .git directory not found. Investigate rather than delete anything.'
}
Remove-Item -LiteralPath $GitPath -Recurse -Force

if (-not (Test-Path -LiteralPath (Join-Path $AppPath 'public\Default.asp'))) {
throw 'Expected framework entry point missing.'
}

Write-Host "Independent Classic ASP starter created at $AppPath"
```

This snippet demonstrates safe initialization but does **not** itself write `AGENTS.md` to the new folder. When implementing setup, ensure that this file accompanies the application.

## Read the project before writing code

Before making any application changes:

- Read `README.md`, `TESTING.md`, and relevant documentation in `docs/`.
- Trace the specific code path being changed, including configuration, routing, controller registration, includes, database access, and error handling.
- Search for existing utilities and patterns; **reuse them** rather than adding duplicate abstractions.
- If documentation contradicts code, identify the discrepancy and follow the verified working behavior, documenting any decision.
- Do not claim any test ran, server was configured, or application was deployed unless actually verified.

## Known RouteKit layout and conventions

The starter README identifies this structure:

```text
public/
Default.asp # IIS front controller; public site root is here
web.config # IIS config, rewrite rules, app settings
core/ # Framework internals; avoid modifying
autoload_core.asp
router.wsc
mvc.asp
lib.*.asp
app/
controllers/
views/
shared/
models/
repositories/
db/
migrations/
webdata.accdb
scripts/
generateController.vbs
generateMigration.vbs
GenerateRepo.vbs
runMigrations.vbs
tests/ # Separate ASPUnit testing harness
README.md
TESTING.md
AGENTS.md # These instructions
```

**IIS site's physical root must normally point to `public/`, not the repository root.** Preserve the framework's routing entry point and startup conventions. Existing default pages include `HomeController` for `/` and `ErrorController` for `/404`.

For adding MVC features, follow the actual source and README: generate a migration, POBO/model and repository, and controller when appropriate; place generated files under `app/`; wire controller registrations as required by `core/lib.ControllerRegistry.asp`, `app/controllers/autoload_controllers.asp`, and routes in `public/Default.asp`. Confirm exact APIs before using them; do not invent framework methods.

## Architecture rules

1. **Classic ASP + VBScript first.** Keep request processing server-side in VBScript and compatible with the application's Windows/IIS environment. Client-side JavaScript is fine for browser UI enhancements.
2. **Respect MVC.** Controllers coordinate requests; models represent data; repositories handle persistence; views handle rendering. Avoid SQL and business logic embedded directly in HTML views.
3. **Protect core.** Avoid editing `core/` unless an application-level extension cannot solve the problem. Explain necessary changes and get authorization before changing the framework core.
4. **Small, scoped changes.** Keep diffs focused and preserve existing behavior. Do not refactor unrelated files.
5. **Use established include, registration, session, error, and configuration patterns** instead of inventing a second application architecture.
6. **No undocumented dependencies.** Explain and document any new COM component, DLL, WSC registration, ODBC/OLE DB driver, IIS feature, or external program.
7. Maintain Windows path and file-encoding compatibility. Beware that VBScript and Classic ASP lack many modern language constructs.

## VBScript, Classic ASP, and COM expertise standards

- Know `Option Explicit`, `Class`, `Property Get/Let/Set`, `Function`, `Sub`, `ByRef`/`ByVal`, `Set`, `Nothing`, `IsObject`, `IsNull`, `IsEmpty`, `Variant`, `Server.CreateObject`, `CreateObject`, `Scripting.Dictionary`, and `RegExp`.
- Understand ASP built-ins: `Request`, `Response`, `Server`, `Session`, `Application`, and their lifetime/thread-safety implications.
- Distinguish browser-side JavaScript from server-side VBScript. Do not use .NET/C# syntax or unsupported VBScript features.
- Be precise with `On Error Resume Next`: restrict its scope, inspect `Err.Number` and `Err.Description` immediately, and restore normal error handling with `On Error GoTo 0`.
- Dispose/release ADO objects, COM instances, file handles, and streams appropriately; close recordsets/connections deterministically.
- Use `ADODB.Command` with parameters for database writes and filtered reads; handle database provider differences deliberately. Never concatenate untrusted input into SQL.
- Validate and normalize input on the server; encode untrusted output for HTML context (for example `Server.HTMLEncode`) and handle URL/JS contexts correctly.
- Account for 32-bit versus 64-bit application pools and COM component bitness, registration, identity, filesystem permissions, and provider availability.
- Use `cscript.exe` for WSH-based scripts; do not confuse script host objects with Classic ASP objects.

## Security requirements

- Do not store secrets in source control, embed credentials in code, expose connection strings or stack traces to end users, or write sensitive request data into logs.
- Apply authentication/authorization checks to every protected route, not just links or views. Follow the existing app's session/auth model where present.
- Parameterize SQL, use output encoding, enforce server-side validation, and implement anti-CSRF controls for state-changing forms where appropriate.
- Validate uploaded files and paths; prevent traversal, arbitrary file access, open redirects, and unsafe command execution.
- Follow least-privilege for application pools and database accounts. Never loosen entire-server settings to fix one application.
- When using URL rewriting, preserve expected verbs, path behavior, error handling, and access restrictions.

## Running locally and testing

Follow README/TESTING.md as current source of truth. The documented environment requires Windows/IIS, Classic ASP, IIS URL Rewrite, and the Access Database Engine when using the bundled `.accdb` database.

- Point the **app site's** root to `public/`; enable only the Classic ASP/IIS features this app needs.
- Configure `public/web.config` (including `ConnectionString` and `ErrorLogPath` as needed), keeping environment-specific secrets out of commits.
- Verify the default `/` welcome page and expected `/404` behavior.
- Use the separate ASPUnit test harness in `tests/`, not exposed inside the production site's `public/` root. Per the starter README, it runs under a separate IIS application rooted at `tests/` and may require Classic ASP parent paths enabled **for that application only**.
- If editing `tests/web.config`, follow the framework's `tests/sync-webconfigs.vbs` procedure.
- Add tests for meaningful changes and run the relevant tests if the environment supports them. Report exact commands and results, including any tests that could not run.
- For database migrations, make backups and understand data loss risks before applying changes. Do not run migrations automatically on production.

## Deployment guardrails

The source framework includes an isolated IIS deployment process documented in `docs/deployment-guide.md` and `docs/deployment-configuration.md`. Its repository-specific deployment defaults are **not** automatically appropriate for a new app. **Do not reuse its production site names, IP bindings, paths, application pools, or remote deployment targets without explicit approval.**

Use local preflight checks when applicable before deployment. Never overwrite or adopt an existing IIS site/app pool. Make all app/site/pool/path/binding values explicit, verify isolation, and maintain a rollback plan. Production deployment requires user authorization.

## Workflow for every coding task

1. **Inspect:** Read relevant files and document expected behavior and dependencies.
2. **Plan:** State briefly which files and application behaviors will change. For a tiny change, a short plan is sufficient.
3. **Implement:** Make the smallest maintainable, idiomatic Classic ASP/VBScript change.
4. **Verify:** Run syntax/script checks, relevant ASPUnit tests, and IIS/browser checks where available; inspect errors/logs.
5. **Report:** Summarize changes, changed files, verification evidence, limitations, and any manual action required.

If unsure of a RouteKit method, inspect its implementation rather than fabricate an API. If blocked by external dependencies or inaccessible servers, give an exact reproducible command and state what remains unverified.

## Definition of done

Work is complete only when changes fit RouteKit conventions, do not unexpectedly modify the framework core, preserve the default application until a feature is specifically requested, meet applicable security requirements, and have verified behavior or clearly documented untested gaps.

+ 1
- 0
CLAUDE.MD Näytä tiedosto

@@ -0,0 +1 @@
@AGENTS.MD

+ 96
- 0
README.md Näytä tiedosto

@@ -0,0 +1,96 @@
# RouteKit Classic ASP - MVC Starter

A clean starting point for building Classic ASP applications with the RouteKit MVC framework.

## Quick Setup

1. Copy this folder to your IIS server
2. Point your IIS site root to the `public/` folder
3. Update `public/web.config`:
- Set `ConnectionString` to your database path
- Set `ErrorLogPath` if you want file logging
4. Ensure the IIS URL Rewrite module is installed
5. Browse to `http://localhost/` — you should see the welcome page

## Project Structure

```
MVC-Starter/
public/ # IIS ROOT - point your IIS site here
Default.asp # Front controller (entry point)
web.config # IIS config, routes, connection strings
core/ # Framework core (do not modify)
autoload_core.asp # Loads all core libraries
router.wsc # Route matching engine
mvc.asp # MVC dispatcher
lib.*.asp # Core libraries
app/
controllers/ # Your controllers go here
views/ # Your views go here
shared/ # Shared layout (header, footer)
models/ # POBOs go here
repositories/ # Repository classes go here
db/
migrations/ # Database migrations
webdata.accdb # Access database
scripts/ # Code generators
generateController.vbs
generateMigration.vbs
GenerateRepo.vbs
runMigrations.vbs
```

## Adding a New Feature

### 1. Generate a migration
```bash
cscript //nologo scripts\generateMigration.vbs create_my_table
```

### 2. Generate POBO and Repository
```bash
cscript //nologo scripts\GenerateRepo.vbs /table:my_table /pk:id
```
Move generated files to `app/models/` and `app/repositories/`.

### 3. Generate a controller
```bash
cscript //nologo scripts\generateController.vbs MyController "Index;Show(id);Create;Store"
```
Move generated file to `app/controllers/`.

### 4. Wire it up
- Register in `core/lib.ControllerRegistry.asp`
- Include in `app/controllers/autoload_controllers.asp`
- Add routes in `public/Default.asp`
- Create views in `app/views/MyController/`

## Included Controllers

- **HomeController** - Welcome page at `/`
- **ErrorController** - 404 handler at `/404`

## Requirements

- Windows Server with IIS
- Classic ASP enabled
- IIS URL Rewrite module
- Microsoft Access Database Engine (for .accdb support)

## Deployment

Production deployment owns an isolated IIS site and app pool; it never targets, adopts, or copies configuration from another site. Defaults are `SiteName=AspClassicUnifiedFramework`, `AppPoolName=AspClassicUnifiedFramework`, `DeployRoot=D:\Deployments\AspClassicUnifiedFramework`, and HTTP binding `100.97.39.23:8085` with an empty host header. Every value is explicitly overridable, while mismatched existing target state fails closed.

The complete repository is retained in immutable release directories and IIS serves only each release's `public/` directory. First deployment initializes shared configuration from packaged `public/web.config` unless `-InitialWebConfigPath` is supplied. The target site/app pool is created only after the staged release validates; Classic ASP parent paths are enabled only at that site's location. Failure cleanup is limited to target resources created by the current invocation, or restoration of the prior valid target state. Migrations remain disabled by default.

Run `scripts/deploy-iis-git.ps1 -LocalPreflightOnly` for local source/XML/package/safety validation with no network access. When host access is permitted, run `-PreflightOnly` for the complete check: it streams the installer without writing remote files and validates IIS features/modules, binding and shared-pool conflicts, drive/path, names, and target state without requiring the target to exist or making IIS/deployment changes. `-HostPreflightOnly` and `-RemotePreflightOnly` remain aliases. Gitea 1.11.4 has no Gitea Actions, so use a trusted external worker or operator workstation. See [docs/deployment-guide.md](docs/deployment-guide.md) and [docs/deployment-configuration.md](docs/deployment-configuration.md).

## Testing

This repo now includes a dev-only `aspunit` harness under `tests/`. It is intentionally separate from the production app rooted at `public/`.

- Configure a separate IIS application rooted at `tests/`
- Ensure Classic ASP parent paths are enabled for that IIS app
- If you change `tests/web.config`, refresh the nested test-folder copies with `cscript //nologo tests\sync-webconfigs.vbs`
- Open `run-all.asp` inside that IIS app to execute the test suite
- See `TESTING.md` for setup, manifest registration, and extension guidance

+ 185
- 0
TESTING.md Näytä tiedosto

@@ -0,0 +1,185 @@
# Testing MVC-Starter

This project now supports a dev-only Classic ASP test harness built with `aspunit`.

## Scope

- Production app: `public/`
- Dev-only test app: `tests/`
- Test framework: `tests/aspunit/`

The `tests/` IIS application assumes the repository layout keeps `tests/`, `public/`, `core/`, and `app/` as sibling directories.

## File Inventory

| Type | Path | Purpose |
| ---- | ---- | ------- |
| Create | `tests/web.config` | IIS/default-document config for the isolated test app |
| Create | `tests/unit/web.config` | Mirrored config for nested unit pages that load config-aware code |
| Create | `tests/component/web.config` | Mirrored config for nested component pages that load config-aware code |
| Create | `tests/integration/web.config` | Mirrored config for nested integration pages that load config-aware code |
| Create | `tests/sync-webconfigs.vbs` | Utility script to mirror `tests/web.config` into nested test folders |
| Create | `tests/run-tests.cmd` | Windows helper to sync configs and open the test runner URL |
| Create | `tests/bootstrap.asp` | Shared test bootstrap and runtime reset helpers |
| Create | `tests/PlainRunnerTheme.asp` | Local runner theme that removes CDN dependence from the test UI |
| Create | `tests/support/HttpCaptureHelpers.asp` | Shared HTTP capture helpers for rendered-page assertions |
| Create | `tests/test-manifest.asp` | Single source of truth for registered test pages |
| Create | `tests/run-all.asp` | Browser runner that aggregates all test pages |
| Vendor | `tests/aspunit/Lib/*` | Upstream aspunit framework files |
| Vendor | `tests/aspunit/LICENSE-MIT` | Upstream aspunit license for vendored third-party code |
| Create | `tests/unit/TestHelpers.asp` | Deterministic helper-function unit tests |
| Create | `tests/unit/TestControllerRegistry.asp` | Controller whitelist/format unit tests |
| Create | `tests/component/TestHomeController.asp` | Controlled component-level controller test |
| Create | `tests/integration/TestMvcDispatch.asp` | Narrow router/dispatch smoke test |
| Create | `tests/integration/TestRoutes.asp` | Route-helper/config integration coverage |
| Create | `tests/integration/TestConfigSettings.asp` | Nested config and fallback behavior coverage |
| Create | `tests/integration/TestRenderedOutput.asp` | Production-page output assertions through safe HTTP capture |
| Create | `tests/integration/TestSharedLayout.asp` | Shared header/footer/layout assertions against rendered production pages |
| Reference | `public/web.config` | Source of mirrored config keys for the test app |
| Reference | `core/helpers.asp` | Helper functions and config-loading behavior under test |
| Reference | `core/mvc.asp` | Dispatcher behavior used by the smoke test |
| Reference | `core/lib.ControllerRegistry.asp` | Whitelist behavior under test |
| Verify | `public/` site | Confirm production app exposes no test routes/pages |

## IIS Setup

1. Keep the existing production IIS app rooted at `public/`.
2. Create a separate development-only IIS application rooted at `tests/`.
3. Enable Classic ASP for that IIS app.
4. Ensure parent paths are allowed for the `tests/` app. This repo ships `tests/web.config` with `enableParentPaths="true"` because the bootstrap and integration pages include sibling files from `../core/` and `../app/`.
5. Browse to the `tests/` app root or directly to `run-all.asp`.
6. If you change `tests/web.config`, run `cscript //nologo tests\sync-webconfigs.vbs` to refresh the nested copies used by the unit, component, and integration pages.
7. If your production app is not served from the same host root as the `tests/` app, set `ProductionAppBaseUrl` in `tests/web.config` and re-run the sync script so rendered-output tests know where to send HTTP requests.
Example: `http://localhost/` for a root site, or `http://localhost/MyClassicApp/` for a virtual-directory app.
8. To sync configs and open the suite in one step on Windows, run `tests\run-tests.cmd` with an optional runner URL argument.

Example layout:

- Production: `http://localhost/`
- Tests: `http://localhost/tests-dev/`

## How It Works

- `tests/run-all.asp` includes the aspunit library and the manifest.
- `tests/run-all.asp` also applies `PlainRunnerTheme.asp`, a local runner theme that avoids the upstream CDN dependency in aspunit’s default UI.
- `tests/test-manifest.asp` explicitly registers each test page.
- `tests/bootstrap.asp` provides the shared runtime setup:
- helper/config access
- controller registry access
- router reset
- `tests/support/HttpCaptureHelpers.asp` provides safe HTTP-based page capture for rendered output assertions against the production app.

The integration test page includes `core/mvc.asp` directly because that is the only first-wave test that needs dispatcher behavior.

Because `GetAppSetting()` uses `Server.MapPath("web.config")`, nested test folders also need a mirrored `web.config` alongside the executing test pages that rely on config-aware runtime files. Use `tests/sync-webconfigs.vbs` after changing `tests/web.config`.

The manifest is manual by design. There is no filesystem auto-discovery.

## Running Tests

Open the browser runner:

Browse to `run-all.asp` within the `tests/` IIS application, for example:

```text
http://localhost/tests-dev/run-all.asp
```

aspunit renders a UI in runner mode and loads each registered page with `?task=test` behind the scenes.

On Windows you can also use:

```bat
tests\run-tests.cmd
```

Or with an explicit runner URL:

```bat
tests\run-tests.cmd http://localhost:8085/run-all.asp
```

## Adding a New Test Page

1. Choose the right folder:
- `tests/unit/` for deterministic helper or registry tests
- `tests/component/` for direct controller/object tests with controlled setup
- `tests/integration/` for narrow runtime smoke coverage, config behavior, or rendered-page capture
- shared layout assertions belong here too, because they verify rendered production responses rather than isolated helper behavior
2. Create a new `.asp` file that:
- includes `../aspunit/Lib/ASPUnit.asp`
- includes `../bootstrap.asp`
- registers one or more modules with `ASPUnit.AddModule(...)`
- calls `ASPUnit.Run()`
3. Add the page path to `tests/test-manifest.asp`.
4. Reload `run-all.asp`.

## First-Pass Isolation Policy

- Unit tests should avoid mutating globals.
- Registry tests should inspect current behavior, not expand the production whitelist.
- Component tests should reset touched singleton/controller state in setup/teardown.
- Dispatch smoke tests should initialize fresh route state before each run.

## What Not To Unit Test

- Full rendered page markup for shared-layout pages unless you add reliable output-capture support.
- Production IIS rewrite behavior from `public/`.
- Broad end-to-end request flows through the production site root.
- Config-dependent behavior that requires machine-specific production values unless you first mirror safe test values into `tests/web.config`.
- Internet access as a requirement for the runner UI. The local theme removes the upstream CDN dependency for first-wave execution.

## Validation Checklist

- `run-all.asp` loads in the separate `tests/` IIS app.
- All manifest pages appear in the runner.
- Helper, registry, component, and integration suites all execute.
- Route-helper/config integration assertions execute from the same isolated IIS app.
- Rendered-page capture assertions can verify production HTML and status codes without polluting aspunit JSON responses.
- Shared layout assertions can verify navbar, asset links, titles, and footer script presence across production-rendered pages.
- Re-running the suite produces stable results.
- The production site under `public/` still exposes no test runner pages or test routes.

## Deployment verification gate

Before a production release:

1. Run the full ASPUnit suite in the isolated development IIS application.
2. Parse every repository `web.config` as XML.
3. Parse both deployment scripts with the Windows PowerShell parser on a Windows CI worker.
4. From a clean standalone checkout of the approved `master` branch, run the local/controller preflight:

```powershell
.\scripts\deploy-iis-git.ps1 -LocalPreflightOnly
```

This validates source provenance, required files, `public/web.config` XML, package creation/extraction, release layout, and package safety without SSH/SCP or host changes.
5. When host connectivity is separately permitted, run the complete read-only preflight (the dedicated target need not exist):

```powershell
.\scripts\deploy-iis-git.ps1 -PreflightOnly -RemoteTarget 'webserver-1'
```

It repeats the local/package checks, streams the installer without writing remote files, and validates IIS/Classic ASP and URL Rewrite, binding and shared-pool conflicts, the deployment drive/path, names, and exact existing-target state without changing IIS or the deployment root.
6. For an isolated Windows test deployment, override names/root/port together rather than reusing any existing site:

```powershell
.\scripts\deploy-iis-git.ps1 `
-SiteName 'AspClassicUnifiedFramework-Test' `
-AppPoolName 'AspClassicUnifiedFramework-Test' `
-DeployRoot 'D:\Deployments\AspClassicUnifiedFramework-Test' `
-BindingIpAddress '100.97.39.23' `
-BindingPort 8185 `
-RemoteTarget 'webserver-1'
```

7. Require the installer smoke test. Also induce a smoke-test failure in the isolated test target and verify that only resources created by that invocation are removed, or that an existing valid target's prior path and parent-path value are restored. Verify unrelated sites, pools, and bindings are unchanged.
8. Run production-safe HTTP checks and prove rollback to a prior immutable release. Never expose the `tests/` IIS application in production.

Linux can validate XML and repository safety/source assertions, but cannot prove Windows PowerShell 5.1 parsing, WebAdministration behavior, installed IIS features/modules, binding behavior on the live host, elevation, app-pool identity/ACLs, Access/ACE, SSH transport, cleanup under real IIS failures, or live HTTP responses. Those remain Windows/IIS gates.

## Limitations

- This harness runs only inside IIS/Classic ASP; it is not intended for Linux execution.
- The repo’s production runtime is still configured via `public/web.config`; the test app uses a minimal mirrored config in `tests/web.config`.
- If the narrow bootstrap is not sufficient for future smoke tests, broaden only the test bootstrap first before considering production runtime changes.

+ 242
- 0
app/controllers/BusinessesController.asp Näytä tiedosto

@@ -0,0 +1,242 @@
<%
Class BusinessesController_Class
Private m_useLayout
Private m_title

Private Sub Class_Initialize()
m_useLayout = True
m_title = "Businesses"
End Sub

Public Property Get useLayout
useLayout = m_useLayout
End Property

Public Property Let useLayout(v)
m_useLayout = v
End Property

Public Property Get Title
Title = m_title
End Property

Public Property Let Title(v)
m_title = v
End Property

'-------------------------------------------------------------------------------------------------------------------
' GET /businesses : searchable, filterable, sortable, paged list
'-------------------------------------------------------------------------------------------------------------------
Public Sub index()
Const PER_PAGE = 50
Dim f, k, page, pageCount, result, rows, total, industries, sort, dir, firstRow, lastRow

Set f = CreateObject("Scripting.Dictionary")
For Each k In Array("q", "industry", "status", "show", "contacted", "phone", "sort", "dir")
f(k) = Trim(CStr(Request.QueryString(k)))
Next
f("q") = Left(f("q"), 100)

page = 1
Dim pageText : pageText = CStr(Request.QueryString("page"))
If Len(pageText) > 0 And Len(pageText) <= 6 Then
If IsNumeric(pageText) Then page = CLng(pageText)
End If
If page < 1 Then page = 1

Set result = BusinessRepository().Search(f, page, PER_PAGE)
total = result("total")
Set rows = result("rows")
Set industries = BusinessRepository().Industries()

pageCount = Int((total + PER_PAGE - 1) / PER_PAGE)
If pageCount < 1 Then pageCount = 1
If page > pageCount Then
page = pageCount
Set result = BusinessRepository().Search(f, page, PER_PAGE)
Set rows = result("rows")
End If

sort = f("sort") : dir = LCase(f("dir"))
If dir <> "desc" Then dir = "asc"
If total = 0 Then firstRow = 0 Else firstRow = (page - 1) * PER_PAGE + 1
lastRow = firstRow + rows.Count - 1
If total = 0 Then lastRow = 0
%>
<!--#include file="../views/Businesses/index.asp" -->
<%
End Sub

'-------------------------------------------------------------------------------------------------------------------
' GET /businesses/:id : detail, history and the "log a touch" form
'-------------------------------------------------------------------------------------------------------------------
Public Sub show(id)
Dim b
If Not Valid_Id(id) Then Response.Redirect "/404"
Set b = BusinessRepository().Find(CLng(id))
If b Is Nothing Then Response.Redirect "/404"
RenderShow id, b, Nothing, Nothing
End Sub

' Renders the detail page. dup (a matching other business) and fv (unsaved form values) are Nothing normally.
Private Sub RenderShow(id, b, dup, fv)
Dim interactions, industries, csrf, today
Set interactions = BusinessRepository().Interactions(CLng(id))
Set industries = BusinessRepository().Industries()
csrf = Csrf_Token("business")
today = Date_Iso(Date)
m_title = b("name")
%>
<!--#include file="../views/Businesses/show.asp" -->
<%
End Sub

'-------------------------------------------------------------------------------------------------------------------
' POST /businesses/:id/update : edit details
'-------------------------------------------------------------------------------------------------------------------
Public Sub update(id)
Dim d, email, phone, indName, indSel
GuardPost id

Set d = CreateObject("Scripting.Dictionary")
d("name") = Left(Trim(F("name")), 255)
If Len(d("name")) = 0 Then
Flash().AddError "Business name is required."
Response.Redirect "/businesses/" & id
End If

email = LCase(Left(Trim(F("email")), 255))
If Len(email) > 0 And InStr(email, "@") = 0 Then
Flash().AddError "That email address doesn't look right, so nothing was saved."
Response.Redirect "/businesses/" & id
End If
phone = Left(Trim(F("phone")), 40)

d("contact_name") = Left(Trim(F("contact_name")), 150)
d("phone") = phone
d("phone_digits") = ImportFile_PhoneDigits(phone)
d("email") = email
d("website") = Left(Trim(F("website")), 255)
d("address1") = Left(Trim(F("address1")), 255)
d("city") = Left(Trim(F("city")), 100)
d("state") = Left(Trim(F("state")), 50)
d("zip") = Left(Trim(F("zip")), 20)
d("notes") = Left(F("notes"), 10000)
If F("is_customer") = "1" Then d("is_customer") = 1 Else d("is_customer") = 0
d("first_order_date") = Date_Parse(F("first_order_date"))

indName = Trim(F("industry_new"))
indSel = F("industry_id")
If Valid_Id(indSel) Then d("industry_id") = CLng(indSel) Else d("industry_id") = Null

' Warn when a changed phone/email is already used by another business (unless "Save anyway" was pressed).
If F("allow_duplicate") <> "1" Then
Dim existing, chkPhone, chkEmail, dupMatch, fv
Set existing = BusinessRepository().Find(CLng(id))
chkPhone = "" : chkEmail = ""
If d("phone_digits") <> existing("phone_digits") & "" Then chkPhone = d("phone_digits")
If d("email") <> existing("email") & "" Then chkEmail = d("email")
Set dupMatch = BusinessRepository().FindDuplicate(CLng(id), chkPhone, chkEmail)
If Not dupMatch Is Nothing Then
Set fv = CreateObject("Scripting.Dictionary")
Dim k
For Each k In d.Keys
fv(k) = d(k)
Next
fv("_industry_new") = indName
RenderShow id, existing, dupMatch, fv
Exit Sub
End If
End If

' A typed-in industry wins over the dropdown; it is only created once the save is going ahead.
If Len(indName) > 0 Then d("industry_id") = BusinessRepository().FindOrCreateIndustry(indName)

BusinessRepository().Update CLng(id), d
Flash().Success = "Saved."
Response.Redirect "/businesses/" & id
End Sub

'-------------------------------------------------------------------------------------------------------------------
' POST /businesses/:id/log : record a call / email / visit / mailing
'-------------------------------------------------------------------------------------------------------------------
Public Sub log(id)
Dim method, outcome, notes, contactedAt, followUp, removing, reason
GuardPost id

method = F("method")
outcome = F("outcome")
If Not Businesses_IsKey(Businesses_Methods(), method) Then
Flash().AddError "Choose how you contacted them."
Response.Redirect "/businesses/" & id
End If
If Len(outcome) > 0 And Not Businesses_IsKey(Businesses_Outcomes(), outcome) Then outcome = ""

contactedAt = Date_Parse(F("contacted_at"))
If IsNull(contactedAt) Then contactedAt = Date
If contactedAt > Date + 1 Then
Flash().AddError "The contact date can't be in the future."
Response.Redirect "/businesses/" & id
End If

followUp = Date_Parse(F("follow_up_date"))
notes = Left(F("notes"), 10000)
removing = (outcome = "remove")
reason = Businesses_Label(Businesses_Outcomes(), outcome)
If removing And Len(Trim(notes)) > 0 Then reason = Left(Trim(notes), 255)

BusinessRepository().LogInteraction CLng(id), method, outcome, notes, contactedAt, followUp, removing, reason

If removing Then
Flash().Success = "Logged and removed from the list."
ElseIf Not IsNull(followUp) Then
Flash().Success = "Logged. Follow-up set for " & Date_Fmt(followUp) & "."
Else
Flash().Success = "Logged."
End If
Response.Redirect "/businesses/" & id
End Sub

'-------------------------------------------------------------------------------------------------------------------
' POST /businesses/:id/remove and /restore
'-------------------------------------------------------------------------------------------------------------------
Public Sub remove(id)
GuardPost id
BusinessRepository().Remove CLng(id), Left(Trim(F("reason")), 255)
Flash().Success = "Removed from the list."
Response.Redirect "/businesses/" & id
End Sub

Public Sub restore(id)
GuardPost id
BusinessRepository().Restore CLng(id)
Flash().Success = "Restored."
Response.Redirect "/businesses/" & id
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Shared checks and helpers
'-------------------------------------------------------------------------------------------------------------------
Private Sub GuardPost(id)
If Not Valid_Id(id) Then Response.Redirect "/404"
If BusinessRepository().Find(CLng(id)) Is Nothing Then Response.Redirect "/404"
If Not Csrf_Valid("business", F("csrf")) Then
Flash().AddError "Invalid form state. Please try again."
Response.Redirect "/businesses/" & id
End If
End Sub

Private Function F(name)
F = CStr(Request.Form(name))
End Function

End Class

Dim BusinessesController_Class__Singleton
Function BusinessesController()
If IsEmpty(BusinessesController_Class__Singleton) Then
Set BusinessesController_Class__Singleton = New BusinessesController_Class
End If
Set BusinessesController = BusinessesController_Class__Singleton
End Function
%>

+ 58
- 0
app/controllers/DashboardController.asp Näytä tiedosto

@@ -0,0 +1,58 @@
<%
Class DashboardController_Class
Private m_useLayout
Private m_title

Private Sub Class_Initialize()
m_useLayout = True
m_title = "Dashboard"
End Sub

Public Property Get useLayout
useLayout = m_useLayout
End Property

Public Property Let useLayout(v)
m_useLayout = v
End Property

Public Property Get Title
Title = m_title
End Property

Public Property Let Title(v)
m_title = v
End Property

'-------------------------------------------------------------------------------------------------------------------
' GET /dashboard : simple counts
'-------------------------------------------------------------------------------------------------------------------
Public Sub index()
Dim counts, activity, daily, byMethod, byOutcome, industries, imports, maxDaily, i
Set counts = StatsRepository().ListCounts()
Set activity = StatsRepository().ActivityCounts()
Set daily = StatsRepository().DailyActivity(14)
Set byMethod = StatsRepository().ActivityBy("method")
Set byOutcome = StatsRepository().ActivityBy("outcome")
Set industries = StatsRepository().TopIndustries(10)
Set imports = StatsRepository().RecentImports(5)

maxDaily = 1
For i = 0 To daily.Count - 1
If daily(i)(1) > maxDaily Then maxDaily = daily(i)(1)
Next
%>
<!--#include file="../views/Dashboard/index.asp" -->
<%
End Sub

End Class

Dim DashboardController_Class__Singleton
Function DashboardController()
If IsEmpty(DashboardController_Class__Singleton) Then
Set DashboardController_Class__Singleton = New DashboardController_Class
End If
Set DashboardController = DashboardController_Class__Singleton
End Function
%>

+ 37
- 0
app/controllers/ErrorController.asp Näytä tiedosto

@@ -0,0 +1,37 @@
<%
Class ErrorController_Class
Private m_useLayout
Private Sub Class_Initialize()
m_useLayout = True
End Sub

Public Property Get useLayout
useLayout = m_useLayout
End Property

Public Property Let useLayout(v)
m_useLayout = v
End Property
Public Sub Index()
Response.Write "Index called"
End Sub

Public Sub NotFound()
Response.Status = "404 Not Found"
%>
<!--#include file="../Views/Error/NotFound.asp" -->
<%
End Sub

End Class

Dim ErrorController_Class__Singleton
Function ErrorController()
If IsEmpty(ErrorController_Class__Singleton) Then
Set ErrorController_Class__Singleton = New ErrorController_Class
End If
Set ErrorController = ErrorController_Class__Singleton
End Function
%>

+ 83
- 0
app/controllers/ExportController.asp Näytä tiedosto

@@ -0,0 +1,83 @@
<%
Class ExportController_Class
Private m_useLayout
Private m_title

Private Sub Class_Initialize()
m_useLayout = False ' streams a file, not a page
m_title = "Export"
End Sub

Public Property Get useLayout
useLayout = m_useLayout
End Property

Public Property Let useLayout(v)
m_useLayout = v
End Property

Public Property Get Title
Title = m_title
End Property

Public Property Let Title(v)
m_title = v
End Property

'-------------------------------------------------------------------------------------------------------------------
' GET /export/businesses : CSV of everything matching the list's search/filters (opens directly in Excel)
'-------------------------------------------------------------------------------------------------------------------
Public Sub businesses()
Dim f, k, rs, line, n, fileName

Set f = CreateObject("Scripting.Dictionary")
For Each k In Array("q", "industry", "status", "show", "contacted", "phone", "sort", "dir")
f(k) = Trim(CStr(Request.QueryString(k)))
Next
f("q") = Left(f("q"), 100)

Server.ScriptTimeout = 600
fileName = "businesses-" & Year(Date) & Right("0" & Month(Date), 2) & Right("0" & Day(Date), 2) & ".csv"

Response.Clear
Response.Buffer = True
Response.CodePage = 65001
Response.Charset = "utf-8"
Response.ContentType = "text/csv"
Response.AddHeader "Content-Disposition", "attachment; filename=""" & fileName & """"

Response.Write ChrW(&HFEFF) ' UTF-8 BOM so Excel reads accents correctly
Response.Write "Business,Contact,Industry,Phone,Email,Website,Address,City,State,Zip,Status,Customer,Last contacted,Next action" & vbCrLf

Set rs = BusinessRepository().ExportRows(f)
n = 0
Do While Not rs.EOF
line = Csv_Cell(rs("name")) & "," & Csv_Cell(rs("contact_name")) & "," & Csv_Cell(rs("industry_name")) & "," & _
Csv_Cell(rs("phone")) & "," & Csv_Cell(rs("email")) & "," & Csv_Cell(rs("website")) & "," & _
Csv_Cell(rs("address1")) & "," & Csv_Cell(rs("city")) & "," & Csv_Cell(rs("state")) & "," & _
Csv_Cell(rs("zip")) & "," & Csv_Cell(Businesses_StatusLabel(rs("status"))) & "," & _
Csv_Cell(CustomerText(rs("is_customer"))) & "," & Csv_Cell(Date_Fmt(rs("last_contacted_at"))) & "," & _
Csv_Cell(Date_Fmt(rs("next_action_date")))
Response.Write line & vbCrLf
n = n + 1
If n Mod 2000 = 0 Then Response.Flush
rs.MoveNext
Loop
rs.Close
Response.End
End Sub

Private Function CustomerText(v)
If v & "" = "1" Then CustomerText = "Yes" Else CustomerText = ""
End Function

End Class

Dim ExportController_Class__Singleton
Function ExportController()
If IsEmpty(ExportController_Class__Singleton) Then
Set ExportController_Class__Singleton = New ExportController_Class
End If
Set ExportController = ExportController_Class__Singleton
End Function
%>

+ 42
- 0
app/controllers/HomeController.asp Näytä tiedosto

@@ -0,0 +1,42 @@
<%
Class HomeController_Class
Private m_useLayout
Private m_title

Private Sub Class_Initialize()
m_useLayout = True
m_title = "Home"
End Sub

Public Property Get useLayout
useLayout = m_useLayout
End Property

Public Property Let useLayout(v)
m_useLayout = v
End Property

Public Property Get Title
Title = m_title
End Property

Public Property Let Title(v)
m_title = v
End Property

Public Sub index()
%>
<!--#include file="../views/Home/index.asp" -->
<%
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
%>

+ 174
- 0
app/controllers/ImportController.asp Näytä tiedosto

@@ -0,0 +1,174 @@
<%
Class ImportController_Class
Private m_useLayout
Private m_title

Private Sub Class_Initialize()
m_useLayout = True
m_title = "Import"
End Sub

Public Property Get useLayout
useLayout = m_useLayout
End Property

Public Property Let useLayout(v)
m_useLayout = v
End Property

Public Property Get Title
Title = m_title
End Property

Public Property Let Title(v)
m_title = v
End Property

'-------------------------------------------------------------------------------------------------------------------
' GET /import : upload form
'-------------------------------------------------------------------------------------------------------------------
Public Sub index()
Dim csrf : csrf = Csrf_Token("import")
%>
<!--#include file="../views/Import/index.asp" -->
<%
End Sub

'-------------------------------------------------------------------------------------------------------------------
' POST /import/upload : store the file, show the column-mapping step
'-------------------------------------------------------------------------------------------------------------------
Public Sub upload()
Dim up, outName, outLocal, ext, token, saved, target, fso, tbl, csrf
Dim headers, rows, sampleCount, fields

Set fso = CreateObject("Scripting.FileSystemObject")
Set up = New FreeASPUpload
up.chunkSize = 1048576
up.Upload

If Not Csrf_Valid("import", up.Form("csrf")) Then
Flash().AddError "Invalid form state. Please try again."
Response.Redirect "/import"
End If

If up.UploadedFiles.Count = 0 Then
Flash().AddError "Choose a .csv, .xlsx or .xls file to import."
Response.Redirect "/import"
End If

up.SaveOne ImportFile_UploadDir(), 0, outName, outLocal
saved = ImportFile_UploadDir() & "\" & outLocal
ext = LCase(Mid(outName, InStrRev(outName, ".") + 1))

If ext <> "csv" And ext <> "xlsx" And ext <> "xls" Then
If fso.FileExists(saved) Then fso.DeleteFile saved, True
Flash().AddError "Only .csv, .xlsx and .xls files can be imported."
Response.Redirect "/import"
End If

token = ImportFile_NewToken()
target = ImportFile_UploadDir() & "\" & token & "." & ext
fso.MoveFile saved, target

Dim readError : readError = ""
On Error Resume Next
Set tbl = ImportFile_Read(target, 5)
If Err.Number <> 0 Then
readError = Err.Description
Err.Clear
End If
On Error GoTo 0

If Len(readError) = 0 Then
If UBound(tbl("headers")) < 0 Then readError = "No columns were found in the first row."
End If

If Len(readError) > 0 Then
If fso.FileExists(target) Then fso.DeleteFile target, True
Flash().AddError "Could not read " & outName & ": " & readError
Response.Redirect "/import"
End If

fields = ImportFile_Fields()
headers = tbl("headers")
Set rows = tbl("rows")
csrf = Csrf_Token("import")
Dim originalName : originalName = outName
%>
<!--#include file="../views/Import/map.asp" -->
<%
End Sub

'-------------------------------------------------------------------------------------------------------------------
' POST /import/run : import every row using the chosen column mapping
'-------------------------------------------------------------------------------------------------------------------
Public Sub run()
Dim token, path, fso, tbl, colOf, i, fieldKey, ncols, fields, res
Dim defaultIndustry, markCustomers, originalName

If Not Csrf_Valid("import", CStr(Request.Form("csrf"))) Then
Flash().AddError "Invalid form state. Please try again."
Response.Redirect "/import"
End If

token = CStr(Request.Form("token"))
path = ImportFile_PathForToken(token)
If Len(path) = 0 Then
Flash().AddError "The uploaded file is no longer available. Please upload it again."
Response.Redirect "/import"
End If

Set colOf = CreateObject("Scripting.Dictionary")
ncols = 0
If IsNumeric(CStr(Request.Form("ncols"))) Then ncols = CLng(CStr(Request.Form("ncols")))
For i = 0 To ncols - 1
fieldKey = CStr(Request.Form("map_" & i))
If Len(fieldKey) > 0 Then
If Not colOf.Exists(fieldKey) Then colOf.Add fieldKey, i
End If
Next

' Only accept known field keys
Dim valid, f, known
fields = ImportFile_Fields()
For Each fieldKey In colOf.Keys
known = False
For Each f In fields
If f(0) = fieldKey Then known = True
Next
If Not known Then colOf.Remove fieldKey
Next

If Not colOf.Exists("name") Then
Flash().AddError "Map one column to ""Business name"" before importing."
Response.Redirect "/import"
End If

defaultIndustry = Left(Trim(CStr(Request.Form("default_industry"))), 100)
markCustomers = (CStr(Request.Form("mark_customers")) = "1")
originalName = Left(CStr(Request.Form("original_name")), 255)

Server.ScriptTimeout = 1800
Set fso = CreateObject("Scripting.FileSystemObject")
Set tbl = ImportFile_Read(path, 0)
Set res = ImportService_Run(tbl, colOf, defaultIndustry, markCustomers, originalName)

If Not res("failed") Then
fso.DeleteFile path, True
HTMLSecurity().ClearAntiCSRFToken "import"
End If
%>
<!--#include file="../views/Import/result.asp" -->
<%
End Sub

End Class

Dim ImportController_Class__Singleton
Function ImportController()
If IsEmpty(ImportController_Class__Singleton) Then
Set ImportController_Class__Singleton = New ImportController_Class
End If
Set ImportController = ImportController_Class__Singleton
End Function
%>

+ 128
- 0
app/controllers/IndustriesController.asp Näytä tiedosto

@@ -0,0 +1,128 @@
<%
Class IndustriesController_Class
Private m_useLayout
Private m_title

Private Sub Class_Initialize()
m_useLayout = True
m_title = "Industries"
End Sub

Public Property Get useLayout
useLayout = m_useLayout
End Property

Public Property Let useLayout(v)
m_useLayout = v
End Property

Public Property Get Title
Title = m_title
End Property

Public Property Let Title(v)
m_title = v
End Property

'-------------------------------------------------------------------------------------------------------------------
' GET /industries
'-------------------------------------------------------------------------------------------------------------------
Public Sub index()
Dim list, uncategorized, csrf
Set list = IndustryRepository().All()
uncategorized = IndustryRepository().UncategorizedCount()
csrf = Csrf_Token("industries")
%>
<!--#include file="../views/Industries/index.asp" -->
<%
End Sub

'-------------------------------------------------------------------------------------------------------------------
' POST /industries/create
'-------------------------------------------------------------------------------------------------------------------
Public Sub create()
Dim name
GuardCsrf
name = Left(Trim(F("name")), 100)
If Len(name) = 0 Then Fail "Enter an industry name."
If IndustryRepository().NameTaken(name, 0) Then Fail """" & name & """ already exists."
IndustryRepository().Create name
Flash().Success = "Added """ & name & """."
Response.Redirect "/industries"
End Sub

'-------------------------------------------------------------------------------------------------------------------
' POST /industries/:id/rename
'-------------------------------------------------------------------------------------------------------------------
Public Sub rename(id)
Dim ind, name
Set ind = Load(id)
name = Left(Trim(F("name")), 100)
If Len(name) = 0 Then Fail "The name can't be blank."
If IndustryRepository().NameTaken(name, ind("id")) Then
Fail """" & name & """ already exists. Use Merge to combine them."
End If
IndustryRepository().Rename ind("id"), name
Flash().Success = "Renamed to """ & name & """."
Response.Redirect "/industries"
End Sub

'-------------------------------------------------------------------------------------------------------------------
' POST /industries/:id/merge : move everything from this industry into another one, then delete this one
'-------------------------------------------------------------------------------------------------------------------
Public Sub merge(id)
Dim ind, target, moved
Set ind = Load(id)
If Not Valid_Id(F("target_id")) Then Fail "Choose the industry to merge into."
If CLng(F("target_id")) = ind("id") Then Fail "Choose a different industry to merge into."
Set target = IndustryRepository().Find(CLng(F("target_id")))
If target Is Nothing Then Fail "That industry no longer exists."
moved = IndustryRepository().Merge(ind("id"), target("id"))
Flash().Success = "Merged """ & ind("name") & """ into """ & target("name") & """ (" & moved & " businesses moved)."
Response.Redirect "/industries"
End Sub

'-------------------------------------------------------------------------------------------------------------------
' POST /industries/:id/delete : only when no business uses it
'-------------------------------------------------------------------------------------------------------------------
Public Sub delete(id)
Dim ind
Set ind = Load(id)
If ind("n") > 0 Then Fail "Can't delete """ & ind("name") & """ while " & ind("n") & " businesses use it. Merge it instead."
IndustryRepository().Delete ind("id")
Flash().Success = "Deleted """ & ind("name") & """."
Response.Redirect "/industries"
End Sub

'-------------------------------------------------------------------------------------------------------------------
Private Function Load(id)
GuardCsrf
If Not Valid_Id(id) Then Response.Redirect "/404"
Dim ind : Set ind = IndustryRepository().Find(CLng(id))
If ind Is Nothing Then Response.Redirect "/404"
Set Load = ind
End Function

Private Sub GuardCsrf()
If Not Csrf_Valid("industries", F("csrf")) Then Fail "Invalid form state. Please try again."
End Sub

Private Sub Fail(msg)
Flash().AddError msg
Response.Redirect "/industries"
End Sub

Private Function F(name)
F = CStr(Request.Form(name))
End Function

End Class

Dim IndustriesController_Class__Singleton
Function IndustriesController()
If IsEmpty(IndustriesController_Class__Singleton) Then
Set IndustriesController_Class__Singleton = New IndustriesController_Class
End If
Set IndustriesController = IndustriesController_Class__Singleton
End Function
%>

+ 64
- 0
app/controllers/TodayController.asp Näytä tiedosto

@@ -0,0 +1,64 @@
<%
Class TodayController_Class
Private m_useLayout
Private m_title

Private Sub Class_Initialize()
m_useLayout = True
m_title = "Today"
End Sub

Public Property Get useLayout
useLayout = m_useLayout
End Property

Public Property Let useLayout(v)
m_useLayout = v
End Property

Public Property Get Title
Title = m_title
End Property

Public Property Let Title(v)
m_title = v
End Property

'-------------------------------------------------------------------------------------------------------------------
' GET /today : follow-ups that are overdue, due today, and coming up this week
'-------------------------------------------------------------------------------------------------------------------
Public Sub index()
Const LOOKAHEAD_DAYS = 7
Dim all, i, r, nextDate, overdue, dueToday, upcoming

Set all = BusinessRepository().DueThrough(Date + LOOKAHEAD_DAYS)
Set overdue = CreateObject("Scripting.Dictionary")
Set dueToday = CreateObject("Scripting.Dictionary")
Set upcoming = CreateObject("Scripting.Dictionary")

For i = 0 To all.Count - 1
Set r = all(i)
nextDate = CDate(r("next_action_date"))
If nextDate < Date Then
overdue.Add overdue.Count, r
ElseIf nextDate = Date Then
dueToday.Add dueToday.Count, r
Else
upcoming.Add upcoming.Count, r
End If
Next
%>
<!--#include file="../views/Today/index.asp" -->
<%
End Sub

End Class

Dim TodayController_Class__Singleton
Function TodayController()
If IsEmpty(TodayController_Class__Singleton) Then
Set TodayController_Class__Singleton = New TodayController_Class
End If
Set TodayController = TodayController_Class__Singleton
End Function
%>

+ 17
- 0
app/controllers/autoload_controllers.asp Näytä tiedosto

@@ -0,0 +1,17 @@
<!--#include file="../lib/lib.Format.asp" -->
<!--#include file="../lib/lib.Csrf.asp" -->
<!--#include file="../lib/lib.Db.asp" -->
<!--#include file="../lib/lib.BusinessHelpers.asp" -->
<!--#include file="../lib/lib.ImportFile.asp" -->
<!--#include file="../lib/lib.ImportService.asp" -->
<!--#include file="../repositories/BusinessRepository.asp" -->
<!--#include file="../repositories/IndustryRepository.asp" -->
<!--#include file="../repositories/StatsRepository.asp" -->
<!--#include file="HomeController.asp" -->
<!--#include file="ErrorController.asp" -->
<!--#include file="TodayController.asp" -->
<!--#include file="BusinessesController.asp" -->
<!--#include file="IndustriesController.asp" -->
<!--#include file="ImportController.asp" -->
<!--#include file="ExportController.asp" -->
<!--#include file="DashboardController.asp" -->

+ 75
- 0
app/lib/lib.BusinessHelpers.asp Näytä tiedosto

@@ -0,0 +1,75 @@
<%
'=======================================================================================================================
' BUSINESS HELPERS: domain vocabulary (touch methods, outcomes, statuses) and list query-string building
'=======================================================================================================================

' Touch methods and outcomes: Array(key, label)
Function Businesses_Methods()
Businesses_Methods = Array(Array("call", "Call"), Array("email", "Email"), Array("visit", "Visit"), Array("mail", "Mailed"))
End Function

Function Businesses_Outcomes()
Businesses_Outcomes = Array( _
Array("no_answer", "No answer"), _
Array("left_voicemail", "Left voicemail"), _
Array("spoke_with_someone", "Spoke with someone"), _
Array("interested", "Interested"), _
Array("follow_up_later", "Follow up later"), _
Array("not_interested", "Not interested"), _
Array("wrong_number", "Wrong number"), _
Array("remove", "Remove from list") _
)
End Function

' Label for a key in one of the Array(key, label) lists above (the key itself when unknown).
Function Businesses_Label(list, key)
Dim item
Businesses_Label = key & ""
For Each item In list
If item(0) = key Then Businesses_Label = item(1)
Next
End Function

Function Businesses_IsKey(list, key)
Dim item
Businesses_IsKey = False
For Each item In list
If item(0) = key Then Businesses_IsKey = True
Next
End Function

Function Businesses_StatusLabel(s)
Select Case s
Case "new": Businesses_StatusLabel = "New"
Case "contacted": Businesses_StatusLabel = "Contacted"
Case "follow_up": Businesses_StatusLabel = "Follow-up"
Case "removed": Businesses_StatusLabel = "Removed"
Case Else: Businesses_StatusLabel = s & ""
End Select
End Function

Function Businesses_StatusClass(s)
Select Case s
Case "new": Businesses_StatusClass = "text-bg-secondary"
Case "contacted": Businesses_StatusClass = "text-bg-info"
Case "follow_up": Businesses_StatusClass = "text-bg-warning"
Case "removed": Businesses_StatusClass = "text-bg-dark"
Case Else: Businesses_StatusClass = "text-bg-light"
End Select
End Function

' Query string for the list: current filters with optional page / sort overrides.
Function Businesses_QS(f, page, sort, dir)
Dim k, s
s = ""
For Each k In Array("q", "industry", "status", "show", "contacted", "phone")
If f.Exists(k) Then
If Len(f(k)) > 0 Then s = s & "&" & k & "=" & Server.URLEncode(f(k))
End If
Next
If Len(sort) > 0 Then s = s & "&sort=" & Server.URLEncode(sort)
If Len(dir) > 0 Then s = s & "&dir=" & Server.URLEncode(dir)
If page > 1 Then s = s & "&page=" & page
If Len(s) > 0 Then Businesses_QS = "?" & Mid(s, 2) Else Businesses_QS = ""
End Function
%>

+ 13
- 0
app/lib/lib.Csrf.asp Näytä tiedosto

@@ -0,0 +1,13 @@
<%
'=======================================================================================================================
' CSRF helpers: thin wrappers over the core HTMLSecurity token (one token per form family name, stored in the session)
'=======================================================================================================================
Function Csrf_Token(name)
Csrf_Token = HTMLSecurity().GetAntiCSRFToken(name)
End Function

' True only for a non-empty token that matches the session's token for this form family.
Function Csrf_Valid(name, token)
Csrf_Valid = (Len(token) > 0 And HTMLSecurity().IsValidAntiCSRFToken(name, token))
End Function
%>

+ 67
- 0
app/lib/lib.Db.asp Näytä tiedosto

@@ -0,0 +1,67 @@
<%
'=======================================================================================================================
' DB HELPERS
' Parameterized query/execute on the shared DAL connection. Parameters are built with the typed helpers below:
' Db_Query "SELECT ... WHERE id = ?", Array(Db_PI(5))
'=======================================================================================================================
Function Db_PS(v)
If IsNull(v) Then
Db_PS = Array(202, Null)
ElseIf Len(v & "") = 0 Then
Db_PS = Array(202, Null)
Else
Db_PS = Array(202, CStr(v))
End If
End Function

Function Db_PI(v)
If IsNull(v) Or IsEmpty(v) Then
Db_PI = Array(3, Null)
ElseIf IsNumeric(v) Then
Db_PI = Array(3, CLng(v))
Else
Db_PI = Array(3, Null)
End If
End Function

Function Db_PD(v)
If IsNull(v) Or IsEmpty(v) Then
Db_PD = Array(7, Null)
ElseIf IsDate(v) Then
Db_PD = Array(7, CDate(v))
Else
Db_PD = Array(7, Null)
End If
End Function

Function Db_Command(sql, params)
Dim cmd, i, p
Set cmd = Server.CreateObject("ADODB.Command")
Set cmd.ActiveConnection = DAL().Connection
cmd.CommandType = 1
cmd.CommandText = sql
For i = 0 To UBound(params)
p = params(i)
If p(0) = 202 Then
If IsNull(p(1)) Then
cmd.Parameters.Append cmd.CreateParameter(, 202, 1, 1, Null)
ElseIf Len(p(1)) > 255 Then
cmd.Parameters.Append cmd.CreateParameter(, 203, 1, Len(p(1)), p(1))
Else
cmd.Parameters.Append cmd.CreateParameter(, 202, 1, Len(p(1)), p(1))
End If
Else
cmd.Parameters.Append cmd.CreateParameter(, p(0), 1, , p(1))
End If
Next
Set Db_Command = cmd
End Function

Function Db_Query(sql, params)
Set Db_Query = Db_Command(sql, params).Execute
End Function

Sub Db_Exec(sql, params)
Db_Command(sql, params).Execute , , 128
End Sub
%>

+ 83
- 0
app/lib/lib.Format.asp Näytä tiedosto

@@ -0,0 +1,83 @@
<%
'=======================================================================================================================
' FORMAT / PARSE HELPERS (generic, not tied to a table)
'=======================================================================================================================

' VBScript has no IIf; this evaluates both branches, so only use it with plain values.
Function Iif_(cond, whenTrue, whenFalse)
If cond Then Iif_ = whenTrue Else Iif_ = whenFalse
End Function

' True for a plain positive integer id (1-9 digits); use before trusting a route/form id.
Function Valid_Id(s)
Dim re : Set re = New RegExp
re.Pattern = "^[0-9]{1,9}$"
Valid_Id = re.Test(s & "")
End Function

' Date -> "mm/dd/yyyy" for display ("" for null / invalid).
Function Date_Fmt(d)
If IsNull(d) Or IsEmpty(d) Then
Date_Fmt = ""
ElseIf IsDate(d) Then
Date_Fmt = Right("0" & Month(d), 2) & "/" & Right("0" & Day(d), 2) & "/" & Year(d)
Else
Date_Fmt = ""
End If
End Function

' Date -> "yyyy-mm-dd" for HTML date inputs.
Function Date_Iso(d)
If IsNull(d) Or IsEmpty(d) Then
Date_Iso = ""
ElseIf IsDate(d) Then
Date_Iso = Year(d) & "-" & Right("0" & Month(d), 2) & "-" & Right("0" & Day(d), 2)
Else
Date_Iso = ""
End If
End Function

' "yyyy-mm-dd" (HTML date input) -> Date, or Null when blank/invalid.
Function Date_Parse(s)
Dim re, m, y, mo, d
Date_Parse = Null
Set re = New RegExp
re.Pattern = "^(\d{4})-(\d{2})-(\d{2})$"
If Not re.Test(s & "") Then Exit Function
Set m = re.Execute(s)(0)
y = CInt(m.SubMatches(0)) : mo = CInt(m.SubMatches(1)) : d = CInt(m.SubMatches(2))
If y < 2000 Or y > 2100 Or mo < 1 Or mo > 12 Or d < 1 Or d > 31 Then Exit Function
If Month(DateSerial(y, mo, d)) <> mo Then Exit Function
Date_Parse = DateSerial(y, mo, d)
End Function

' HTML-encodes text and turns line breaks into <br>.
Function Html_Nl2Br(s)
Html_Nl2Br = Replace(Replace(Replace(Server.HTMLEncode(s & ""), vbCrLf, "<br>"), vbLf, "<br>"), vbCr, "<br>")
End Function

' Quotes a value for CSV. Values that a spreadsheet would treat as a formula are prefixed with an apostrophe
' (CSV injection), except ordinary phone numbers like +1 (555) 123-4567.
Function Csv_Cell(v)
Dim s, first, re
If IsNull(v) Or IsEmpty(v) Then
Csv_Cell = ""
Exit Function
End If
s = CStr(v)
If Len(s) > 0 Then
first = Left(s, 1)
If first = "=" Or first = "@" Or first = vbTab Or first = vbCr Then
s = "'" & s
ElseIf first = "+" Or first = "-" Then
Set re = New RegExp
re.Pattern = "^[+\-][0-9 ().\-]*$"
If Not re.Test(s) Then s = "'" & s
End If
End If
If InStr(s, ",") > 0 Or InStr(s, """") > 0 Or InStr(s, vbCr) > 0 Or InStr(s, vbLf) > 0 Or Left(s, 1) = " " Or Right(s, 1) = " " Then
s = """" & Replace(s, """", """""") & """"
End If
Csv_Cell = s
End Function
%>

+ 304
- 0
app/lib/lib.ImportFile.asp Näytä tiedosto

@@ -0,0 +1,304 @@
<%
'=======================================================================================================================
' IMPORT FILE HELPERS
' Reads CSV / XLSX / XLS uploads into a header array + rows dictionary, and normalizes values for the businesses table.
'
' ImportFile_Read(path, maxRows) returns a Scripting.Dictionary:
' "headers" -> Array of column names
' "rows" -> Scripting.Dictionary (0-based index -> Array of string values), at most maxRows rows (0 = all)
'=======================================================================================================================

Function ImportFile_UploadDir()
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim dir : dir = fso.GetAbsolutePathName(Server.MapPath("/") & "\..\uploads")
If Not fso.FolderExists(dir) Then fso.CreateFolder dir
ImportFile_UploadDir = dir
End Function

' Returns the full path of the stored upload for a token, or "" when the token is malformed or the file is missing.
Function ImportFile_PathForToken(token)
Dim re : Set re = New RegExp
re.Pattern = "^[0-9A-Fa-f]{32}$"
ImportFile_PathForToken = ""
If Not re.Test(token) Then Exit Function

Dim fso, ext, p
Set fso = CreateObject("Scripting.FileSystemObject")
For Each ext In Array("csv", "xlsx", "xls")
p = ImportFile_UploadDir() & "\" & token & "." & ext
If fso.FileExists(p) Then
ImportFile_PathForToken = p
Exit Function
End If
Next
End Function

Function ImportFile_NewToken()
Dim tl : Set tl = CreateObject("Scriptlet.TypeLib")
ImportFile_NewToken = Replace(Replace(Replace(Left(CStr(tl.Guid), 38), "{", ""), "}", ""), "-", "")
Set tl = Nothing
End Function

Function ImportFile_Read(path, maxRows)
Dim ext : ext = LCase(Mid(path, InStrRev(path, ".") + 1))
If ext = "csv" Then
Set ImportFile_Read = ImportFile_ReadCsv(path, maxRows)
Else
Set ImportFile_Read = ImportFile_ReadExcel(path, ext, maxRows)
End If
End Function

'---------------------------------------------------------------------------------------------------------------------
' CSV
'---------------------------------------------------------------------------------------------------------------------
Function ImportFile_ReadCsv(path, maxRows)
Dim stm, text
Set stm = Server.CreateObject("ADODB.Stream")
stm.Type = 2
stm.Charset = "utf-8"
stm.Open
stm.LoadFromFile path
text = stm.ReadText
stm.Close
' Not valid UTF-8 (replacement character present): re-read as Windows-1252, which is what Excel "CSV" exports use.
If InStr(text, ChrW(65533)) > 0 Then
stm.Charset = "windows-1252"
stm.Open
stm.LoadFromFile path
text = stm.ReadText
stm.Close
End If
Set stm = Nothing

text = Replace(text, vbCrLf, vbLf)
text = Replace(text, vbCr, vbLf)

' Pick the delimiter that appears most in the first line.
Dim firstLine, delim, best, cand, c
firstLine = Left(text, InStr(text & vbLf, vbLf) - 1)
delim = ","
best = 0
For Each cand In Array(",", ";", vbTab, "|")
c = Len(firstLine) - Len(Replace(firstLine, cand, ""))
If c > best Then best = c : delim = cand
Next

Dim lines, i, line, pending, all, rec
lines = Split(text, vbLf)
Set all = CreateObject("Scripting.Dictionary")
pending = ""
For i = 0 To UBound(lines)
line = lines(i)
If Len(pending) > 0 Then
line = pending & vbLf & line
pending = ""
End If
' An odd number of quotes means a quoted field continues onto the next physical line.
If ((Len(line) - Len(Replace(line, """", ""))) Mod 2) = 1 And i < UBound(lines) Then
pending = line
ElseIf Len(Trim(line)) > 0 Then
all.Add all.Count, ImportFile_SplitCsvLine(line, delim)
If maxRows > 0 And all.Count > maxRows Then Exit For
End If
Next

Set ImportFile_ReadCsv = ImportFile_Pack(all)
End Function

Function ImportFile_SplitCsvLine(line, delim)
If InStr(line, """") = 0 Then
ImportFile_SplitCsvLine = Split(line, delim)
Exit Function
End If

Dim fields(), n, i, ch, cur, inQ
ReDim fields(Len(line))
n = 0 : cur = "" : inQ = False : i = 1
Do While i <= Len(line)
ch = Mid(line, i, 1)
If inQ Then
If ch = """" Then
If Mid(line, i + 1, 1) = """" Then
cur = cur & """"
i = i + 1
Else
inQ = False
End If
Else
cur = cur & ch
End If
ElseIf ch = """" Then
inQ = True
ElseIf ch = delim Then
fields(n) = cur : n = n + 1 : cur = ""
Else
cur = cur & ch
End If
i = i + 1
Loop
fields(n) = cur
ReDim Preserve fields(n)
ImportFile_SplitCsvLine = fields
End Function

'---------------------------------------------------------------------------------------------------------------------
' Excel (via ACE OLEDB; 32-bit provider, so this only works in a 32-bit app pool / IIS Express x86)
'---------------------------------------------------------------------------------------------------------------------
Function ImportFile_ReadExcel(path, ext, maxRows)
Dim conn, rs, schema, sheet, props, i, n, all, rec, v, ncols
If ext = "xls" Then props = "Excel 8.0" Else props = "Excel 12.0 Xml"

Set conn = Server.CreateObject("ADODB.Connection")
conn.Open "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & path & ";Extended Properties=""" & props & ";HDR=YES;IMEX=1"";"

Set schema = conn.OpenSchema(20) ' adSchemaTables
sheet = ""
Do While Not schema.EOF
If schema("TABLE_TYPE") = "TABLE" Or schema("TABLE_TYPE") = "SYSTEM TABLE" Then
If InStr(schema("TABLE_NAME"), "_xlnm") = 0 And InStr(schema("TABLE_NAME"), "FilterDatabase") = 0 Then
sheet = schema("TABLE_NAME")
Exit Do
End If
End If
schema.MoveNext
Loop
schema.Close

Set all = CreateObject("Scripting.Dictionary")
If Len(sheet) > 0 Then
Set rs = Server.CreateObject("ADODB.Recordset")
rs.Open "SELECT * FROM [" & sheet & "]", conn, 0, 1
ncols = rs.Fields.Count

ReDim rec(ncols - 1)
For i = 0 To ncols - 1
rec(i) = rs.Fields(i).Name
Next
all.Add 0, rec

Do While Not rs.EOF
ReDim rec(ncols - 1)
For i = 0 To ncols - 1
v = rs.Fields(i).Value
If IsNull(v) Then rec(i) = "" Else rec(i) = Trim(CStr(v))
Next
all.Add all.Count, rec
If maxRows > 0 And all.Count > maxRows Then Exit Do
rs.MoveNext
Loop
rs.Close
End If
conn.Close
Set ImportFile_ReadExcel = ImportFile_Pack(all)
End Function

' Splits the raw row dictionary (row 0 = header) into headers + data rows.
Function ImportFile_Pack(all)
Dim result, rows, i
Set result = CreateObject("Scripting.Dictionary")
Set rows = CreateObject("Scripting.Dictionary")
If all.Count = 0 Then
result.Add "headers", Array()
Else
Dim hdr : hdr = all(0)
For i = 0 To UBound(hdr)
hdr(i) = Trim(Replace(hdr(i), ChrW(65279), ""))
Next
result.Add "headers", hdr
For i = 1 To all.Count - 1
rows.Add rows.Count, all(i)
Next
End If
result.Add "rows", rows
Set ImportFile_Pack = result
End Function

Function ImportFile_Cell(rec, idx)
ImportFile_Cell = ""
If idx >= 0 Then
If idx <= UBound(rec) Then ImportFile_Cell = Trim(rec(idx))
End If
End Function

'=======================================================================================================================
' FIELD DEFINITIONS AND NORMALIZATION
'=======================================================================================================================

' Importable fields: Array(key, label)
Function ImportFile_Fields()
ImportFile_Fields = Array( _
Array("name", "Business name"), _
Array("contact_name", "Contact name"), _
Array("industry", "Industry / type of business"), _
Array("phone", "Phone"), _
Array("email", "Email"), _
Array("website", "Website"), _
Array("address1", "Address"), _
Array("city", "City"), _
Array("state", "State"), _
Array("zip", "Zip"), _
Array("notes", "Notes") _
)
End Function

' Guesses which field a column header represents ("" = ignore).
Function ImportFile_GuessField(header)
Dim h : h = LCase(Trim(header))
Dim rules, r
rules = Array( _
Array("contact_name", "contact|owner|person|first.?name|full.?name"), _
Array("email", "e-?mail"), _
Array("phone", "phone|tel|mobile|cell"), _
Array("website", "web|url|site"), _
Array("industry", "industry|category|categories|business.?type|type|niche|sic|naics"), _
Array("zip", "zip|postal|post.?code"), _
Array("state", "^st$|state|province|region"), _
Array("city", "city|town"), _
Array("address1", "address|street"), _
Array("notes", "note|comment|description"), _
Array("name", "business|company|org|^name$|name") _
)
Dim re : Set re = New RegExp
re.IgnoreCase = True
For Each r In rules
re.Pattern = r(1)
If re.Test(h) Then
ImportFile_GuessField = r(0)
Exit Function
End If
Next
ImportFile_GuessField = ""
End Function

' Phone as digits only (leading US country code dropped); "" when fewer than 7 digits.
Function ImportFile_PhoneDigits(phone)
Dim re, d
Set re = New RegExp
re.Global = True
re.Pattern = "[^0-9]"
d = re.Replace(phone, "")
If Len(d) = 11 And Left(d, 1) = "1" Then d = Mid(d, 2)
If Len(d) < 7 Then d = ""
ImportFile_PhoneDigits = Left(d, 20)
End Function

' Digits of a search term, without the 7-digit minimum used for stored phone numbers.
Function ImportFile_PhoneDigitsLoose(s)
Dim re : Set re = New RegExp
re.Global = True
re.Pattern = "[^0-9]"
ImportFile_PhoneDigitsLoose = re.Replace(s, "")
End Function

' Zip codes that lost their leading zero in Excel (4 digits) get it back.
Function ImportFile_NormalizeZip(zip)
Dim z : z = Trim(zip)
If Len(z) > 2 Then
If Right(z, 2) = ".0" Then
If IsNumeric(Left(z, Len(z) - 2)) Then z = Left(z, Len(z) - 2)
End If
End If
If Len(z) = 4 And IsNumeric(z) Then z = "0" & z
ImportFile_NormalizeZip = z
End Function
%>

+ 211
- 0
app/lib/lib.ImportService.asp Näytä tiedosto

@@ -0,0 +1,211 @@
<%
'=======================================================================================================================
' IMPORT SERVICE
' Inserts parsed spreadsheet rows into businesses inside one transaction.
' Duplicates (same phone digits OR same email) are skipped, both against existing rows and within the file itself.
'=======================================================================================================================

Function ImportService_TextParam(cmd, size)
cmd.Parameters.Append cmd.CreateParameter(, 202, 1, size, Null) ' adVarWChar, adParamInput
End Function

Function ImportService_NullIfEmpty(s)
If Len(s) = 0 Then ImportService_NullIfEmpty = Null Else ImportService_NullIfEmpty = s
End Function

' tbl : result of ImportFile_Read(path, 0)
' colOf : Dictionary field key -> column index (only mapped fields)
' defaultIndustry : industry name used when a row has none ("" = leave blank)
' markCustomers : True to flag every imported row as a previous customer
' Returns a Dictionary: read, added, dup_db, dup_file, no_name, new_industries, failed, error, batch_id, dups (Dictionary of samples)
Function ImportService_Run(tbl, colOf, defaultIndustry, markCustomers, fileName)
Dim res : Set res = CreateObject("Scripting.Dictionary")
res("read") = 0 : res("added") = 0 : res("dup_db") = 0 : res("dup_file") = 0
res("no_name") = 0 : res("new_industries") = 0 : res("failed") = False : res("error") = ""
res("batch_id") = 0
Dim dups : Set dups = CreateObject("Scripting.Dictionary")
Set res("dups") = dups

Dim conn : Set conn = DAL().Connection
Dim rs, phones, emails, industries

Set phones = CreateObject("Scripting.Dictionary") : phones.CompareMode = 1
Set emails = CreateObject("Scripting.Dictionary") : emails.CompareMode = 1
Set industries = CreateObject("Scripting.Dictionary") : industries.CompareMode = 1

Set rs = conn.Execute("SELECT phone_digits, email FROM businesses")
Do While Not rs.EOF
If Len(rs(0) & "") > 0 Then phones(rs(0) & "") = 1
If Len(rs(1) & "") > 0 Then emails(LCase(rs(1) & "")) = 1
rs.MoveNext
Loop
rs.Close

Set rs = conn.Execute("SELECT id, name FROM industries")
Do While Not rs.EOF
industries(rs(1) & "") = CLng(rs(0))
rs.MoveNext
Loop
rs.Close

' Prepared insert for businesses
Dim cmd : Set cmd = Server.CreateObject("ADODB.Command")
Set cmd.ActiveConnection = conn
cmd.CommandType = 1
cmd.CommandText = "INSERT INTO businesses (name, contact_name, industry_id, phone, phone_digits, email, website, " & _
"address1, city, state, zip, source, status, is_customer, notes, import_batch_id, created_at) " & _
"VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,Now())"
ImportService_TextParam cmd, 255 ' name
ImportService_TextParam cmd, 150 ' contact_name
cmd.Parameters.Append cmd.CreateParameter(, 3, 1, , Null) ' industry_id
ImportService_TextParam cmd, 40 ' phone
ImportService_TextParam cmd, 20 ' phone_digits
ImportService_TextParam cmd, 255 ' email
ImportService_TextParam cmd, 255 ' website
ImportService_TextParam cmd, 255 ' address1
ImportService_TextParam cmd, 100 ' city
ImportService_TextParam cmd, 50 ' state
ImportService_TextParam cmd, 20 ' zip
ImportService_TextParam cmd, 255 ' source
ImportService_TextParam cmd, 20 ' status
cmd.Parameters.Append cmd.CreateParameter(, 3, 1, , 0) ' is_customer
cmd.Parameters.Append cmd.CreateParameter(, 203, 1, 4000, Null) ' notes (adLongVarWChar)
cmd.Parameters.Append cmd.CreateParameter(, 3, 1, , 0) ' import_batch_id

Dim indCmd : Set indCmd = Server.CreateObject("ADODB.Command")
Set indCmd.ActiveConnection = conn
indCmd.CommandType = 1
indCmd.CommandText = "INSERT INTO industries (name) VALUES (?)"
ImportService_TextParam indCmd, 100

Dim rows : Set rows = tbl("rows")
Dim i, rec, nm, contact, ind, phone, digits, email, website, addr, city, st, zip, notes
Dim indId, reason, srcLabel, cust, k

srcLabel = Left(fileName, 255)
If markCustomers Then cust = 1 Else cust = 0

On Error Resume Next
conn.BeginTrans

' Batch row (counts are updated at the end)
conn.Execute "INSERT INTO import_batches (file_name, imported_at, rows_read, rows_added, rows_skipped) VALUES ('" & _
Replace(Left(fileName, 255), "'", "''") & "', Now(), 0, 0, 0)", , 128
If Err.Number = 0 Then
Set rs = conn.Execute("SELECT @@IDENTITY")
res("batch_id") = CLng(rs(0))
rs.Close
End If

If Err.Number = 0 Then
For i = 0 To rows.Count - 1
If Err.Number <> 0 Then Exit For
rec = rows(i)
res("read") = res("read") + 1

nm = Left(ImportFile_Cell(rec, ImportService_Col(colOf, "name")), 255)
If Len(nm) = 0 Then
res("no_name") = res("no_name") + 1
Else
contact = Left(ImportFile_Cell(rec, ImportService_Col(colOf, "contact_name")), 150)
ind = Left(ImportFile_Cell(rec, ImportService_Col(colOf, "industry")), 100)
phone = Left(ImportFile_Cell(rec, ImportService_Col(colOf, "phone")), 40)
email = Left(ImportFile_Cell(rec, ImportService_Col(colOf, "email")), 255)
website = Left(ImportFile_Cell(rec, ImportService_Col(colOf, "website")), 255)
addr = Left(ImportFile_Cell(rec, ImportService_Col(colOf, "address1")), 255)
city = Left(ImportFile_Cell(rec, ImportService_Col(colOf, "city")), 100)
st = Left(ImportFile_Cell(rec, ImportService_Col(colOf, "state")), 50)
zip = Left(ImportFile_NormalizeZip(ImportFile_Cell(rec, ImportService_Col(colOf, "zip"))), 20)
notes = Left(ImportFile_Cell(rec, ImportService_Col(colOf, "notes")), 4000)

If InStr(email, "@") = 0 Then email = ""
email = LCase(email)
digits = ImportFile_PhoneDigits(phone)

reason = ""
If Len(digits) > 0 Then
If phones.Exists(digits) Then reason = "phone"
End If
If Len(reason) = 0 And Len(email) > 0 Then
If emails.Exists(email) Then reason = "email"
End If

If Len(reason) > 0 Then
If (reason = "phone" And phones(digits) = 2) Or (reason = "email" And emails(email) = 2) Then
res("dup_file") = res("dup_file") + 1
Else
res("dup_db") = res("dup_db") + 1
End If
If dups.Count < 25 Then dups.Add dups.Count, Array(i + 2, nm, reason)
Else
' Resolve industry (create when new)
indId = Null
If Len(ind) = 0 Then ind = defaultIndustry
If Len(ind) > 0 Then
If industries.Exists(ind) Then
indId = industries(ind)
Else
indCmd.Parameters(0).Value = ind
indCmd.Execute , , 128
If Err.Number <> 0 Then Exit For
Set rs = conn.Execute("SELECT @@IDENTITY")
indId = CLng(rs(0))
rs.Close
industries(ind) = indId
res("new_industries") = res("new_industries") + 1
End If
End If

cmd.Parameters(0).Value = nm
cmd.Parameters(1).Value = ImportService_NullIfEmpty(contact)
cmd.Parameters(2).Value = indId
cmd.Parameters(3).Value = ImportService_NullIfEmpty(phone)
cmd.Parameters(4).Value = ImportService_NullIfEmpty(digits)
cmd.Parameters(5).Value = ImportService_NullIfEmpty(email)
cmd.Parameters(6).Value = ImportService_NullIfEmpty(website)
cmd.Parameters(7).Value = ImportService_NullIfEmpty(addr)
cmd.Parameters(8).Value = ImportService_NullIfEmpty(city)
cmd.Parameters(9).Value = ImportService_NullIfEmpty(st)
cmd.Parameters(10).Value = ImportService_NullIfEmpty(zip)
cmd.Parameters(11).Value = ImportService_NullIfEmpty(srcLabel)
cmd.Parameters(12).Value = "new"
cmd.Parameters(13).Value = cust
cmd.Parameters(14).Value = ImportService_NullIfEmpty(notes)
cmd.Parameters(15).Value = res("batch_id")
cmd.Execute , , 128
If Err.Number <> 0 Then Exit For

res("added") = res("added") + 1
If Len(digits) > 0 Then phones(digits) = 2
If Len(email) > 0 Then emails(email) = 2
End If
End If
Next
End If

If Err.Number <> 0 Then
res("failed") = True
res("error") = "Row " & (res("read") + 1) & ": " & Err.Description
Err.Clear
conn.RollbackTrans
Else
conn.Execute "UPDATE import_batches SET rows_read = " & CLng(res("read")) & ", rows_added = " & CLng(res("added")) & _
", rows_skipped = " & CLng(res("read") - res("added")) & " WHERE id = " & CLng(res("batch_id")), , 128
If Err.Number <> 0 Then
res("failed") = True
res("error") = Err.Description
Err.Clear
conn.RollbackTrans
Else
conn.CommitTrans
End If
End If
On Error GoTo 0

Set ImportService_Run = res
End Function

Function ImportService_Col(colOf, key)
If colOf.Exists(key) Then ImportService_Col = colOf(key) Else ImportService_Col = -1
End Function
%>

+ 392
- 0
app/repositories/BusinessRepository.asp Näytä tiedosto

@@ -0,0 +1,392 @@
<%
'=======================================================================================================================
' BUSINESS REPOSITORY
' Data access for businesses and their logged contacts (interactions). Everything is bound as ADODB parameters
' through the Db_* helpers (app/lib/lib.Db.asp).
'
' List filters (Scripting.Dictionary, all optional):
' q free text: every whitespace-separated term must match name, contact, email, city or phone
' industry "" = any, "0" = no industry, otherwise an industries.id
' status "active" (default, hides removed), "all", or new | contacted | follow_up | removed
' show "" = everyone, "prospects", "customers"
' contacted "never" = only businesses with no contact yet
' phone "1" = only businesses with a phone number
' sort name | city | industry | status | last_contacted | next_action | added (default name)
' dir asc | desc
'=======================================================================================================================
Class BusinessRepository_Class
Private m_where
Private m_params ' Dictionary index -> Array(adoType, value), in the order of the ? markers in m_where

'---------------------------------------------------------------------------------------------------------------------
' Lists
'---------------------------------------------------------------------------------------------------------------------

' One page of the filtered list. Returns Dictionary("rows" -> Dictionary of row Dictionaries, "total" -> count).
Public Function Search(f, page, perPage)
Dim result, rows, total, rs, i, skip, sql

BuildWhere f

Set rs = Run("SELECT COUNT(*) AS n FROM businesses b WHERE " & m_where)
total = CLng(rs("n"))
rs.Close

If page < 1 Then page = 1
skip = (page - 1) * perPage

' Access has no OFFSET: read TOP (skip + perPage) rows and step past the first `skip` of them.
sql = "SELECT TOP " & CLng(skip + perPage) & " b.id, b.name, b.contact_name, b.phone, b.email, b.website, " & _
"b.city, b.state, b.status, b.is_customer, b.last_contacted_at, b.next_action_date, i.name AS industry_name " & _
"FROM businesses b LEFT JOIN industries i ON i.id = b.industry_id " & _
"WHERE " & m_where & " ORDER BY " & OrderByClause(f)

Set rs = Run(sql)
For i = 1 To skip
If rs.EOF Then Exit For
rs.MoveNext
Next
Set rows = ReadRows(rs)
rs.Close

Set result = CreateObject("Scripting.Dictionary")
Set result("rows") = rows
result("total") = total
Set Search = result
End Function

' Every business matching the filters (no paging), as a forward-only recordset for streaming to CSV.
Public Function ExportRows(f)
BuildWhere f
Set ExportRows = Run("SELECT b.name, b.contact_name, i.name AS industry_name, b.phone, b.email, b.website, " & _
"b.address1, b.city, b.state, b.zip, b.status, b.is_customer, b.last_contacted_at, b.next_action_date " & _
"FROM businesses b LEFT JOIN industries i ON i.id = b.industry_id " & _
"WHERE " & m_where & " ORDER BY " & OrderByClause(f))
End Function

' Businesses with a next-contact date on or before throughDate (removed ones excluded), oldest first,
' each with the details of its most recent logged contact.
Public Function DueThrough(throughDate)
Dim list, rs, i, ids, notesById, k, sql
sql = "SELECT TOP 500 b.id, b.name, b.contact_name, b.phone, b.email, b.city, b.state, b.is_customer, " & _
"b.next_action_date, b.last_contacted_at, i.name AS industry_name, " & _
"(SELECT TOP 1 x.method FROM interactions x WHERE x.business_id = b.id ORDER BY x.contacted_at DESC, x.id DESC) AS last_method, " & _
"(SELECT TOP 1 x.outcome FROM interactions x WHERE x.business_id = b.id ORDER BY x.contacted_at DESC, x.id DESC) AS last_outcome, " & _
"(SELECT TOP 1 x.id FROM interactions x WHERE x.business_id = b.id ORDER BY x.contacted_at DESC, x.id DESC) AS last_interaction_id " & _
"FROM businesses b LEFT JOIN industries i ON i.id = b.industry_id " & _
"WHERE b.next_action_date IS NOT NULL AND b.next_action_date <= ? AND b.status <> 'removed' " & _
"ORDER BY b.next_action_date ASC, b.name ASC"
Set rs = Db_Query(sql, Array(Db_PD(throughDate)))
Set list = ReadRows(rs)
rs.Close

' Notes are a memo field, which Access won't return from a TOP 1 subquery, so fetch them by interaction id.
ids = ""
For i = 0 To list.Count - 1
If Not IsNull(list(i)("last_interaction_id")) Then
If Len(ids) > 0 Then ids = ids & ","
ids = ids & CLng(list(i)("last_interaction_id"))
End If
Next
Set notesById = CreateObject("Scripting.Dictionary")
If Len(ids) > 0 Then
Set rs = Db_Query("SELECT id, notes FROM interactions WHERE id IN (" & ids & ")", Array())
Do While Not rs.EOF
notesById(CStr(rs(0))) = rs(1) & ""
rs.MoveNext
Loop
rs.Close
End If
For i = 0 To list.Count - 1
list(i)("last_notes") = ""
If Not IsNull(list(i)("last_interaction_id")) Then
k = CStr(list(i)("last_interaction_id"))
If notesById.Exists(k) Then list(i)("last_notes") = notesById(k)
End If
Next
Set DueThrough = list
End Function

' id -> name, for dropdowns
Public Function Industries()
Dim list, rs
Set list = CreateObject("Scripting.Dictionary")
Set rs = Db_Query("SELECT id, name FROM industries ORDER BY name", Array())
Do While Not rs.EOF
list.Add CStr(rs(0)), rs(1) & ""
rs.MoveNext
Loop
rs.Close
Set Industries = list
End Function

'---------------------------------------------------------------------------------------------------------------------
' One business and its history
'---------------------------------------------------------------------------------------------------------------------

' All columns plus industry_name, or Nothing.
Public Function Find(id)
Dim rs, rows
Set rs = Db_Query("SELECT b.*, i.name AS industry_name FROM businesses b LEFT JOIN industries i ON i.id = b.industry_id WHERE b.id = ?", Array(Db_PI(id)))
Set rows = ReadRows(rs)
rs.Close
If rows.Count = 0 Then Set Find = Nothing Else Set Find = rows(0)
End Function

' Logged contacts for a business, newest first.
Public Function Interactions(businessId)
Dim rs
Set rs = Db_Query("SELECT id, method, outcome, notes, contacted_at, follow_up_date FROM interactions WHERE business_id = ? ORDER BY contacted_at DESC, id DESC", Array(Db_PI(businessId)))
Set Interactions = ReadRows(rs)
rs.Close
End Function

' Another business (not excludeId) with the same phone digits or the same email, or Nothing.
' Returns Dictionary(id, name, matched) where matched is "phone" or "email".
Public Function FindDuplicate(excludeId, phoneDigits, email)
Dim d
Set FindDuplicate = Nothing
If Len(phoneDigits) > 0 Then
Set d = FirstMatch("SELECT TOP 1 id, name FROM businesses WHERE id <> ? AND phone_digits = ?", Array(Db_PI(excludeId), Db_PS(phoneDigits)), "phone")
If Not d Is Nothing Then
Set FindDuplicate = d
Exit Function
End If
End If
If Len(email) > 0 Then
Set FindDuplicate = FirstMatch("SELECT TOP 1 id, name FROM businesses WHERE id <> ? AND email = ?", Array(Db_PI(excludeId), Db_PS(email)), "email")
End If
End Function

' Returns the industry id for a name, creating the industry when it does not exist. Null for a blank name.
Public Function FindOrCreateIndustry(name)
Dim rs
name = Left(Trim(name), 100)
If Len(name) = 0 Then
FindOrCreateIndustry = Null
Exit Function
End If
Set rs = Db_Query("SELECT id FROM industries WHERE name = ?", Array(Db_PS(name)))
If Not rs.EOF Then
FindOrCreateIndustry = CLng(rs(0))
rs.Close
Exit Function
End If
rs.Close
Db_Exec "INSERT INTO industries (name) VALUES (?)", Array(Db_PS(name))
Set rs = Db_Query("SELECT @@IDENTITY", Array())
FindOrCreateIndustry = CLng(rs(0))
rs.Close
End Function

'---------------------------------------------------------------------------------------------------------------------
' Changes
'---------------------------------------------------------------------------------------------------------------------

Public Sub Update(id, d)
Db_Exec "UPDATE businesses SET name = ?, contact_name = ?, industry_id = ?, phone = ?, phone_digits = ?, email = ?, " & _
"website = ?, address1 = ?, city = ?, state = ?, zip = ?, notes = ?, is_customer = ?, first_order_date = ? WHERE id = ?", _
Array(Db_PS(d("name")), Db_PS(d("contact_name")), Db_PI(d("industry_id")), Db_PS(d("phone")), Db_PS(d("phone_digits")), Db_PS(d("email")), _
Db_PS(d("website")), Db_PS(d("address1")), Db_PS(d("city")), Db_PS(d("state")), Db_PS(d("zip")), Db_PS(d("notes")), _
Db_PI(d("is_customer")), Db_PD(d("first_order_date")), Db_PI(id))
End Sub

' Logs a touch and updates the business in one transaction:
' removing -> status removed, no next action
' follow-up date -> status follow_up, next_action_date = follow-up date
' otherwise -> status contacted, next_action_date cleared
Public Sub LogInteraction(id, method, outcome, notes, contactedAt, followUp, removing, removeReason)
Dim conn, b, status, nextAction, lastContacted, remReason, remAt, msg
Set conn = DAL().Connection
Set b = Find(id)
lastContacted = contactedAt
If Not IsNull(b("last_contacted_at")) Then
If CDate(b("last_contacted_at")) > contactedAt Then lastContacted = CDate(b("last_contacted_at"))
End If

remReason = Null : remAt = Null : nextAction = Null
If removing Then
status = "removed"
remReason = removeReason
remAt = Now()
ElseIf Not IsNull(followUp) Then
status = "follow_up"
nextAction = followUp
Else
status = "contacted"
End If

conn.BeginTrans
On Error Resume Next
Db_Exec "INSERT INTO interactions (business_id, method, outcome, notes, contacted_at, follow_up_date, created_at) VALUES (?,?,?,?,?,?,Now())", _
Array(Db_PI(id), Db_PS(method), Db_PS(outcome), Db_PS(notes), Db_PD(contactedAt), Db_PD(followUp))
If Err.Number = 0 Then
Db_Exec "UPDATE businesses SET last_contacted_at = ?, status = ?, next_action_date = ?, removed_reason = ?, removed_at = ? WHERE id = ?", _
Array(Db_PD(lastContacted), Db_PS(status), Db_PD(nextAction), Db_PS(remReason), Db_PD(remAt), Db_PI(id))
End If
If Err.Number <> 0 Then
msg = Err.Description
Err.Clear
conn.RollbackTrans
On Error GoTo 0
Err.Raise 5, "BusinessRepository.LogInteraction", msg
End If
conn.CommitTrans
On Error GoTo 0
End Sub

Public Sub Remove(id, reason)
Db_Exec "UPDATE businesses SET status = 'removed', next_action_date = NULL, removed_reason = ?, removed_at = Now() WHERE id = ?", _
Array(Db_PS(reason), Db_PI(id))
End Sub

Public Sub Restore(id)
Db_Exec "UPDATE businesses SET status = IIf(last_contacted_at IS NULL, 'new', 'contacted'), removed_reason = NULL, removed_at = NULL WHERE id = ?", _
Array(Db_PI(id))
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Internals
'---------------------------------------------------------------------------------------------------------------------

' Reads every remaining row of the recordset into a Dictionary (0-based index -> Dictionary of column -> value).
Private Function ReadRows(rs)
Dim list, d, i
Set list = CreateObject("Scripting.Dictionary")
Do While Not rs.EOF
Set d = CreateObject("Scripting.Dictionary")
For i = 0 To rs.Fields.Count - 1
d(rs.Fields(i).Name) = rs.Fields(i).Value
Next
list.Add list.Count, d
rs.MoveNext
Loop
Set ReadRows = list
End Function

' Runs a query expected to return (id, name) and wraps the first row as Dictionary(id, name, matched), or Nothing.
Private Function FirstMatch(sql, params, matched)
Dim rs, d
Set FirstMatch = Nothing
Set rs = Db_Query(sql, params)
If Not rs.EOF Then
Set d = CreateObject("Scripting.Dictionary")
d("id") = CLng(rs(0)) : d("name") = rs(1) & "" : d("matched") = matched
Set FirstMatch = d
End If
rs.Close
End Function

' Executes sql with the parameters collected by BuildWhere.
Private Function Run(sql)
Dim params(), i
If m_params.Count = 0 Then
Set Run = Db_Query(sql, Array())
Exit Function
End If
ReDim params(m_params.Count - 1)
For i = 0 To m_params.Count - 1
params(i) = m_params(i)
Next
Set Run = Db_Query(sql, params)
End Function

Private Sub AddParam(typ, v)
m_params.Add m_params.Count, Array(typ, v)
End Sub

Private Sub BuildWhere(f)
Dim terms, t, d, q, n, frag, ind, st
m_where = "1=1"
Set m_params = CreateObject("Scripting.Dictionary")

q = Trim(Val_(f, "q"))
If Len(q) > 0 Then
terms = Split(q, " ")
n = 0
For Each t In terms
If Len(t) > 0 And n < 5 Then
n = n + 1
t = Left(t, 50)
d = ImportFile_PhoneDigitsLoose(t)
frag = "(b.name LIKE ? OR b.contact_name LIKE ? OR b.email LIKE ? OR b.city LIKE ?"
AddParam 202, "%" & Like_(t) & "%"
AddParam 202, "%" & Like_(t) & "%"
AddParam 202, "%" & Like_(t) & "%"
AddParam 202, "%" & Like_(t) & "%"
If Len(d) >= 3 Then
frag = frag & " OR b.phone_digits LIKE ?"
AddParam 202, "%" & d & "%"
End If
m_where = m_where & " AND " & frag & ")"
End If
Next
End If

ind = Val_(f, "industry")
If ind = "0" Then
m_where = m_where & " AND b.industry_id IS NULL"
ElseIf Valid_Id(ind) Then
m_where = m_where & " AND b.industry_id = ?"
AddParam 3, CLng(ind)
End If

st = Val_(f, "status")
Select Case st
Case "all"
Case "new", "contacted", "follow_up", "removed"
m_where = m_where & " AND b.status = ?"
AddParam 202, st
Case Else
m_where = m_where & " AND b.status <> 'removed'"
End Select

Select Case Val_(f, "show")
Case "prospects"
m_where = m_where & " AND (b.is_customer = 0 OR b.is_customer IS NULL)"
Case "customers"
m_where = m_where & " AND b.is_customer = 1"
End Select

If Val_(f, "contacted") = "never" Then m_where = m_where & " AND b.last_contacted_at IS NULL"
If Val_(f, "phone") = "1" Then m_where = m_where & " AND b.phone_digits IS NOT NULL"
End Sub

Private Function OrderByClause(f)
Dim col, dirSql
Select Case Val_(f, "sort")
Case "city": col = "b.city"
Case "industry": col = "i.name"
Case "status": col = "b.status"
Case "last_contacted": col = "b.last_contacted_at"
Case "next_action": col = "b.next_action_date"
Case "added": col = "b.created_at"
Case Else: col = "b.name"
End Select
If LCase(Val_(f, "dir")) = "desc" Then dirSql = "DESC" Else dirSql = "ASC"
OrderByClause = col & " " & dirSql & ", b.id " & dirSql
End Function

Private Function Val_(f, key)
If f.Exists(key) Then Val_ = CStr(f(key)) Else Val_ = ""
End Function

' Escape LIKE wildcards so user input is matched literally.
Private Function Like_(s)
s = Replace(s, "[", "[[]")
s = Replace(s, "%", "[%]")
s = Replace(s, "_", "[_]")
s = Replace(s, "*", "[*]")
s = Replace(s, "?", "[?]")
Like_ = s
End Function
End Class

Dim BusinessRepository_Class__Singleton
Function BusinessRepository()
If IsEmpty(BusinessRepository_Class__Singleton) Then
Set BusinessRepository_Class__Singleton = New BusinessRepository_Class
End If
Set BusinessRepository = BusinessRepository_Class__Singleton
End Function
%>

+ 94
- 0
app/repositories/IndustryRepository.asp Näytä tiedosto

@@ -0,0 +1,94 @@
<%
'=======================================================================================================================
' INDUSTRY REPOSITORY
'=======================================================================================================================
Class IndustryRepository_Class

' All industries with the number of businesses in each: list of Dictionary(id, name, n)
Public Function All()
Dim list, rs, d
Set list = CreateObject("Scripting.Dictionary")
Set rs = Db_Query("SELECT i.id, i.name, COUNT(b.id) AS n FROM industries i LEFT JOIN businesses b ON b.industry_id = i.id GROUP BY i.id, i.name ORDER BY i.name", Array())
Do While Not rs.EOF
Set d = CreateObject("Scripting.Dictionary")
d("id") = CLng(rs(0)) : d("name") = rs(1) & "" : d("n") = CLng(rs(2))
list.Add list.Count, d
rs.MoveNext
Loop
rs.Close
Set All = list
End Function

Public Function UncategorizedCount()
Dim rs
Set rs = Db_Query("SELECT COUNT(*) FROM businesses WHERE industry_id IS NULL", Array())
UncategorizedCount = CLng(rs(0))
rs.Close
End Function

Public Function Find(id)
Dim rs
Set rs = Db_Query("SELECT i.id, i.name, (SELECT COUNT(*) FROM businesses b WHERE b.industry_id = i.id) AS n FROM industries i WHERE i.id = ?", Array(Db_PI(id)))
If rs.EOF Then
Set Find = Nothing
Else
Dim d : Set d = CreateObject("Scripting.Dictionary")
d("id") = CLng(rs(0)) : d("name") = rs(1) & "" : d("n") = CLng(rs(2))
Set Find = d
End If
rs.Close
End Function

' True when another industry (not excludeId) already has this name (case-insensitive).
Public Function NameTaken(name, excludeId)
Dim rs
Set rs = Db_Query("SELECT COUNT(*) FROM industries WHERE name = ? AND id <> ?", Array(Db_PS(name), Db_PI(excludeId)))
NameTaken = (CLng(rs(0)) > 0)
rs.Close
End Function

Public Sub Create(name)
Db_Exec "INSERT INTO industries (name) VALUES (?)", Array(Db_PS(name))
End Sub

Public Sub Rename(id, name)
Db_Exec "UPDATE industries SET name = ? WHERE id = ?", Array(Db_PS(name), Db_PI(id))
End Sub

' Moves every business from sourceId to targetId, then deletes sourceId. Returns the number of businesses moved.
Public Function Merge(sourceId, targetId)
Dim conn, moved, rs, msg
Set conn = DAL().Connection
Set rs = Db_Query("SELECT COUNT(*) FROM businesses WHERE industry_id = ?", Array(Db_PI(sourceId)))
moved = CLng(rs(0))
rs.Close

conn.BeginTrans
On Error Resume Next
Db_Exec "UPDATE businesses SET industry_id = ? WHERE industry_id = ?", Array(Db_PI(targetId), Db_PI(sourceId))
If Err.Number = 0 Then Db_Exec "DELETE FROM industries WHERE id = ?", Array(Db_PI(sourceId))
If Err.Number <> 0 Then
msg = Err.Description
Err.Clear
conn.RollbackTrans
On Error GoTo 0
Err.Raise 5, "IndustryRepository.Merge", msg
End If
conn.CommitTrans
On Error GoTo 0
Merge = moved
End Function

Public Sub Delete(id)
Db_Exec "DELETE FROM industries WHERE id = ?", Array(Db_PI(id))
End Sub
End Class

Dim IndustryRepository_Class__Singleton
Function IndustryRepository()
If IsEmpty(IndustryRepository_Class__Singleton) Then
Set IndustryRepository_Class__Singleton = New IndustryRepository_Class
End If
Set IndustryRepository = IndustryRepository_Class__Singleton
End Function
%>

+ 123
- 0
app/repositories/StatsRepository.asp Näytä tiedosto

@@ -0,0 +1,123 @@
<%
'=======================================================================================================================
' STATS REPOSITORY
' Read-only counts for the dashboard.
'=======================================================================================================================
Class StatsRepository_Class

' Dictionary of counts about the list itself
Public Function ListCounts()
Dim rs, d
Set d = CreateObject("Scripting.Dictionary")
Set rs = Db_Query( _
"SELECT COUNT(*) AS total, " & _
"Sum(IIf(status = 'removed', 1, 0)) AS removed, " & _
"Sum(IIf(status <> 'removed' AND (is_customer = 0 OR is_customer IS NULL), 1, 0)) AS prospects, " & _
"Sum(IIf(status <> 'removed' AND is_customer = 1, 1, 0)) AS customers, " & _
"Sum(IIf(status <> 'removed' AND (is_customer = 0 OR is_customer IS NULL) AND last_contacted_at IS NULL, 1, 0)) AS never_contacted, " & _
"Sum(IIf(status = 'new', 1, 0)) AS st_new, " & _
"Sum(IIf(status = 'contacted', 1, 0)) AS st_contacted, " & _
"Sum(IIf(status = 'follow_up', 1, 0)) AS st_follow_up, " & _
"Sum(IIf(status <> 'removed' AND next_action_date < Date(), 1, 0)) AS overdue, " & _
"Sum(IIf(status <> 'removed' AND next_action_date = Date(), 1, 0)) AS due_today, " & _
"Sum(IIf(status <> 'removed' AND next_action_date > Date() AND next_action_date <= DateAdd('d', 7, Date()), 1, 0)) AS this_week, " & _
"Sum(IIf(status <> 'removed' AND phone_digits IS NULL, 1, 0)) AS no_phone " & _
"FROM businesses", Array())
Dim i
For i = 0 To rs.Fields.Count - 1
d(rs.Fields(i).Name) = N(rs.Fields(i).Value)
Next
rs.Close
d("active") = d("total") - d("removed")
Set ListCounts = d
End Function

' Counts of logged contacts: today, last 7 days (including today), last 30 days
Public Function ActivityCounts()
Dim rs, d
Set d = CreateObject("Scripting.Dictionary")
Set rs = Db_Query( _
"SELECT Sum(IIf(contacted_at = Date(), 1, 0)) AS n_today, " & _
"Sum(IIf(contacted_at >= DateAdd('d', -6, Date()), 1, 0)) AS n_week, " & _
"Sum(IIf(contacted_at >= DateAdd('d', -29, Date()), 1, 0)) AS n_month, " & _
"COUNT(*) AS everything FROM interactions", Array())
d("today") = N(rs("n_today")) : d("week") = N(rs("n_week")) : d("month") = N(rs("n_month")) : d("all") = N(rs("everything"))
rs.Close
Set ActivityCounts = d
End Function

' Contacts per day for the last `days` days, oldest first: list of Array(date, count) including zero days
Public Function DailyActivity(days)
Dim rs, counts, list, i, dt, key
Set counts = CreateObject("Scripting.Dictionary")
Set rs = Db_Query("SELECT contacted_at, COUNT(*) FROM interactions WHERE contacted_at >= DateAdd('d', " & CLng(1 - days) & ", Date()) GROUP BY contacted_at", Array())
Do While Not rs.EOF
If Not IsNull(rs(0)) Then counts(CStr(CLng(CDate(rs(0))))) = CLng(rs(1))
rs.MoveNext
Loop
rs.Close
Set list = CreateObject("Scripting.Dictionary")
For i = days - 1 To 0 Step -1
dt = Date - i
key = CStr(CLng(dt))
If counts.Exists(key) Then list.Add list.Count, Array(dt, counts(key)) Else list.Add list.Count, Array(dt, 0)
Next
Set DailyActivity = list
End Function

' Last 30 days grouped by a column ("method" or "outcome"): list of Array(key, count), biggest first
Public Function ActivityBy(column)
Dim rs, list
If column <> "method" And column <> "outcome" Then Err.Raise 5, "StatsRepository.ActivityBy", "Unsupported column"
Set list = CreateObject("Scripting.Dictionary")
Set rs = Db_Query("SELECT " & column & ", COUNT(*) AS n FROM interactions WHERE contacted_at >= DateAdd('d', -29, Date()) GROUP BY " & column & " ORDER BY COUNT(*) DESC", Array())
Do While Not rs.EOF
list.Add list.Count, Array(rs(0) & "", CLng(rs(1)))
rs.MoveNext
Loop
rs.Close
Set ActivityBy = list
End Function

' Biggest industries (active businesses only) with how many have been contacted at least once
Public Function TopIndustries(maxRows)
Dim rs, list
Set list = CreateObject("Scripting.Dictionary")
Set rs = Db_Query( _
"SELECT TOP " & CLng(maxRows) & " i.id, i.name, COUNT(b.id) AS n, Sum(IIf(b.last_contacted_at IS NULL, 0, 1)) AS contacted " & _
"FROM industries i INNER JOIN businesses b ON b.industry_id = i.id WHERE b.status <> 'removed' " & _
"GROUP BY i.id, i.name ORDER BY COUNT(b.id) DESC, i.name", Array())
Do While Not rs.EOF
list.Add list.Count, Array(CLng(rs(0)), rs(1) & "", CLng(rs(2)), N(rs(3)))
rs.MoveNext
Loop
rs.Close
Set TopIndustries = list
End Function

Public Function RecentImports(maxRows)
Dim rs, list
Set list = CreateObject("Scripting.Dictionary")
Set rs = Db_Query("SELECT TOP " & CLng(maxRows) & " id, file_name, imported_at, rows_read, rows_added FROM import_batches ORDER BY id DESC", Array())
Do While Not rs.EOF
list.Add list.Count, Array(CLng(rs(0)), rs(1) & "", rs(2), N(rs(3)), N(rs(4)))
rs.MoveNext
Loop
rs.Close
Set RecentImports = list
End Function

' Null -> 0
Private Function N(v)
If IsNull(v) Or IsEmpty(v) Then N = 0 Else N = CLng(v)
End Function
End Class

Dim StatsRepository_Class__Singleton
Function StatsRepository()
If IsEmpty(StatsRepository_Class__Singleton) Then
Set StatsRepository_Class__Singleton = New StatsRepository_Class
End If
Set StatsRepository = StatsRepository_Class__Singleton
End Function
%>

+ 153
- 0
app/views/Businesses/index.asp Näytä tiedosto

@@ -0,0 +1,153 @@
<% Flash().ShowErrorsIfPresent : Flash().ShowSuccessIfPresent %>

<div class="d-flex justify-content-between align-items-center mb-3">
<h1 class="h3 mb-0">Businesses</h1>
<div class="d-flex gap-2">
<a href="/export/businesses<%= H(Businesses_QS(f, 1, sort, dir)) %>" class="btn btn-outline-success btn-sm" title="Download everything matching the current search and filters as a spreadsheet (CSV)"><i class="bi bi-download"></i> Export<% If total > 0 Then Response.Write " " & FormatNumber(total, 0) %></a>
<a href="/import" class="btn btn-outline-primary btn-sm"><i class="bi bi-upload"></i> Import</a>
</div>
</div>

<form method="get" action="/businesses" class="card shadow-sm mb-3">
<div class="card-body">
<div class="row g-2 align-items-end">
<div class="col-lg-4">
<label for="q" class="form-label small mb-1">Search</label>
<input type="text" class="form-control form-control-sm" id="q" name="q" value="<%= H(f("q")) %>" placeholder="Name, contact, email, city or phone" maxlength="100" />
</div>
<div class="col-6 col-lg-2">
<label for="industry" class="form-label small mb-1">Industry</label>
<select class="form-select form-select-sm" id="industry" name="industry">
<option value="">Any</option>
<option value="0"<% If f("industry") = "0" Then Response.Write " selected" %>>(No industry)</option>
<% Dim indKey : For Each indKey In industries.Keys %>
<option value="<%= indKey %>"<% If f("industry") = indKey Then Response.Write " selected" %>><%= H(industries(indKey)) %></option>
<% Next %>
</select>
</div>
<div class="col-6 col-lg-2">
<label for="status" class="form-label small mb-1">Status</label>
<select class="form-select form-select-sm" id="status" name="status">
<option value=""<% If f("status") = "" Or f("status") = "active" Then Response.Write " selected" %>>Active (not removed)</option>
<option value="all"<% If f("status") = "all" Then Response.Write " selected" %>>All</option>
<option value="new"<% If f("status") = "new" Then Response.Write " selected" %>>New</option>
<option value="contacted"<% If f("status") = "contacted" Then Response.Write " selected" %>>Contacted</option>
<option value="follow_up"<% If f("status") = "follow_up" Then Response.Write " selected" %>>Follow-up</option>
<option value="removed"<% If f("status") = "removed" Then Response.Write " selected" %>>Removed</option>
</select>
</div>
<div class="col-6 col-lg-2">
<label for="show" class="form-label small mb-1">Show</label>
<select class="form-select form-select-sm" id="show" name="show">
<option value="">Everyone</option>
<option value="prospects"<% If f("show") = "prospects" Then Response.Write " selected" %>>Prospects only</option>
<option value="customers"<% If f("show") = "customers" Then Response.Write " selected" %>>Previous customers</option>
</select>
</div>
<div class="col-6 col-lg-2">
<div class="form-check mb-1">
<input class="form-check-input" type="checkbox" id="contacted" name="contacted" value="never"<% If f("contacted") = "never" Then Response.Write " checked" %> />
<label class="form-check-label small" for="contacted">Never contacted</label>
</div>
<div class="form-check mb-1">
<input class="form-check-input" type="checkbox" id="phone" name="phone" value="1"<% If f("phone") = "1" Then Response.Write " checked" %> />
<label class="form-check-label small" for="phone">Has a phone number</label>
</div>
</div>
</div>
<div class="mt-2">
<button type="submit" class="btn btn-primary btn-sm"><i class="bi bi-search"></i> Search</button>
<a href="/businesses" class="btn btn-link btn-sm">Reset</a>
</div>
</div>
</form>

<%
' Sort header helper values (functions cannot be declared in a view, so build the links inline)
Dim cols, ci, colKey, colLabel, nextDir, arrow
cols = Array(Array("name", "Business"), Array("industry", "Industry"), Array("city", "Location"), _
Array("status", "Status"), Array("last_contacted", "Last contacted"), Array("next_action", "Next action"))
%>

<p class="text-muted small mb-2">
<% If total = 0 Then %>
No businesses match.
<% Else %>
Showing <%= FormatNumber(firstRow, 0) %>&ndash;<%= FormatNumber(lastRow, 0) %> of <%= FormatNumber(total, 0) %>
<% End If %>
</p>

<div class="card shadow-sm mb-3">
<div class="table-responsive">
<table class="table table-sm table-hover align-middle mb-0">
<thead class="table-light">
<tr>
<% For ci = 0 To UBound(cols)
colKey = cols(ci)(0) : colLabel = cols(ci)(1)
nextDir = "asc" : arrow = ""
If (sort = colKey) Or (sort = "" And colKey = "name") Then
If dir = "asc" Then nextDir = "desc" : arrow = " <i class=""bi bi-caret-up-fill""></i>" Else nextDir = "asc" : arrow = " <i class=""bi bi-caret-down-fill""></i>"
End If
%>
<th><a class="text-decoration-none text-dark" href="/businesses<%= H(Businesses_QS(f, 1, colKey, nextDir)) %>"><%= colLabel %><%= arrow %></a></th>
<% Next %>
<th>Contact</th>
</tr>
</thead>
<tbody>
<% Dim ri, r, due
For ri = 0 To rows.Count - 1
Set r = rows(ri)
%>
<tr>
<td>
<a class="fw-semibold text-decoration-none" href="/businesses/<%= r("id") %>"><%= H(r("name")) %></a>
<% If r("is_customer") = 1 Then %><span class="badge text-bg-success ms-1">Customer</span><% End If %>
<% If Len(r("contact_name") & "") > 0 Then %><div class="small text-muted"><%= H(r("contact_name")) %></div><% End If %>
</td>
<td><%= H(r("industry_name")) %></td>
<td><%= H(r("city")) %><% If Len(r("city") & "") > 0 And Len(r("state") & "") > 0 Then Response.Write ", " %><%= H(r("state")) %></td>
<td><span class="badge <%= Businesses_StatusClass(r("status")) %>"><%= Businesses_StatusLabel(r("status")) %></span></td>
<td class="small"><%= Date_Fmt(r("last_contacted_at")) %></td>
<td class="small<% due = False
If Not IsNull(r("next_action_date")) Then
If IsDate(r("next_action_date")) Then due = (CDate(r("next_action_date")) < Date)
End If
If due Then Response.Write " text-danger fw-semibold" %>"><%= Date_Fmt(r("next_action_date")) %></td>
<td class="small">
<% If Len(r("phone") & "") > 0 Then %><div><a href="tel:<%= H(r("phone")) %>" class="text-decoration-none"><%= H(r("phone")) %></a></div><% End If %>
<% If Len(r("email") & "") > 0 Then %><div><a href="mailto:<%= H(r("email")) %>" class="text-decoration-none"><%= H(r("email")) %></a></div><% End If %>
</td>
</tr>
<% Next %>
<% If rows.Count = 0 Then %>
<tr><td colspan="7" class="text-center text-muted py-4">Nothing to show. Try different filters, or <a href="/import">import a list</a>.</td></tr>
<% End If %>
</tbody>
</table>
</div>
</div>

<% If pageCount > 1 Then
Dim pFrom, pTo, pi
pFrom = page - 3 : If pFrom < 1 Then pFrom = 1
pTo = page + 3 : If pTo > pageCount Then pTo = pageCount
%>
<nav aria-label="Pages">
<ul class="pagination pagination-sm justify-content-center">
<li class="page-item<% If page = 1 Then Response.Write " disabled" %>"><a class="page-link" href="/businesses<%= H(Businesses_QS(f, page - 1, sort, dir)) %>">Previous</a></li>
<% If pFrom > 1 Then %>
<li class="page-item"><a class="page-link" href="/businesses<%= H(Businesses_QS(f, 1, sort, dir)) %>">1</a></li>
<% If pFrom > 2 Then %><li class="page-item disabled"><span class="page-link">&hellip;</span></li><% End If %>
<% End If %>
<% For pi = pFrom To pTo %>
<li class="page-item<% If pi = page Then Response.Write " active" %>"><a class="page-link" href="/businesses<%= H(Businesses_QS(f, pi, sort, dir)) %>"><%= pi %></a></li>
<% Next %>
<% If pTo < pageCount Then %>
<% If pTo < pageCount - 1 Then %><li class="page-item disabled"><span class="page-link">&hellip;</span></li><% End If %>
<li class="page-item"><a class="page-link" href="/businesses<%= H(Businesses_QS(f, pageCount, sort, dir)) %>"><%= pageCount %></a></li>
<% End If %>
<li class="page-item<% If page = pageCount Then Response.Write " disabled" %>"><a class="page-link" href="/businesses<%= H(Businesses_QS(f, page + 1, sort, dir)) %>">Next</a></li>
</ul>
</nav>
<% End If %>

+ 260
- 0
app/views/Businesses/show.asp Näytä tiedosto

@@ -0,0 +1,260 @@
<%
Dim isRemoved, isCustomer, bid, mth, oc, ix, it, indKey2, nextDue
If fv Is Nothing Then Set fv = b
isRemoved = (b("status") & "" = "removed")
isCustomer = (b("is_customer") & "" = "1")
bid = CLng(id)
nextDue = False
If Not IsNull(b("next_action_date")) Then
If IsDate(b("next_action_date")) Then nextDue = (CDate(b("next_action_date")) <= Date)
End If
%>
<% Flash().ShowErrorsIfPresent : Flash().ShowSuccessIfPresent %>

<nav aria-label="breadcrumb">
<ol class="breadcrumb small mb-2">
<li class="breadcrumb-item"><a href="/businesses">Businesses</a></li>
<li class="breadcrumb-item active" aria-current="page"><%= H(b("name")) %></li>
</ol>
</nav>

<div class="d-flex flex-wrap align-items-center gap-2 mb-3">
<h1 class="h3 mb-0"><%= H(b("name")) %></h1>
<span class="badge <%= Businesses_StatusClass(b("status")) %>"><%= Businesses_StatusLabel(b("status")) %></span>
<% If isCustomer Then %><span class="badge text-bg-success">Customer</span><% End If %>
<% If Len(b("industry_name") & "") > 0 Then %><span class="badge text-bg-light border"><%= H(b("industry_name")) %></span><% End If %>
</div>

<% If isRemoved Then %>
<div class="alert alert-dark d-flex justify-content-between align-items-center">
<div>
<strong>Removed</strong><% If Not IsNull(b("removed_at")) Then Response.Write " on " & Date_Fmt(b("removed_at")) %>.
<% If Len(b("removed_reason") & "") > 0 Then %>Reason: <%= H(b("removed_reason")) %><% End If %>
</div>
<form method="post" action="/businesses/<%= bid %>/restore" class="mb-0">
<input type="hidden" name="csrf" value="<%= H(csrf) %>" />
<button type="submit" class="btn btn-sm btn-outline-dark">Restore to list</button>
</form>
</div>
<% ElseIf Not IsNull(b("next_action_date")) Then %>
<div class="alert <% If nextDue Then Response.Write "alert-warning" Else Response.Write "alert-info" %> py-2">
<i class="bi bi-calendar-event"></i> Next contact: <strong><%= Date_Fmt(b("next_action_date")) %></strong><% If nextDue Then Response.Write " &mdash; due" %>
</div>
<% End If %>

<div class="row g-3">
<!-- LEFT: log a touch + history -->
<div class="col-lg-7">
<% If Not isRemoved Then %>
<div class="card shadow-sm mb-3">
<div class="card-body">
<h2 class="h5 mb-3">Log a contact</h2>
<form method="post" action="/businesses/<%= bid %>/log" id="logForm">
<input type="hidden" name="csrf" value="<%= H(csrf) %>" />

<div class="mb-3">
<div class="btn-group" role="group" aria-label="How">
<% For Each mth In Businesses_Methods() %>
<input type="radio" class="btn-check" name="method" id="m_<%= mth(0) %>" value="<%= mth(0) %>" autocomplete="off"<% If mth(0) = "call" Then Response.Write " checked" %> />
<label class="btn btn-outline-primary btn-sm" for="m_<%= mth(0) %>"><%= H(mth(1)) %></label>
<% Next %>
</div>
</div>

<div class="row g-2 mb-2">
<div class="col-md-5">
<label for="outcome" class="form-label small mb-1">Outcome</label>
<select class="form-select form-select-sm" id="outcome" name="outcome">
<option value="">&mdash;</option>
<% For Each oc In Businesses_Outcomes() %>
<option value="<%= oc(0) %>"><%= H(oc(1)) %></option>
<% Next %>
</select>
</div>
<div class="col-6 col-md-3">
<label for="contacted_at" class="form-label small mb-1">Date</label>
<input type="date" class="form-control form-control-sm" id="contacted_at" name="contacted_at" value="<%= today %>" max="<%= Date_Iso(Date + 1) %>" />
</div>
<div class="col-6 col-md-4">
<label for="follow_up_date" class="form-label small mb-1">Contact again on</label>
<input type="date" class="form-control form-control-sm" id="follow_up_date" name="follow_up_date" value="" />
</div>
</div>

<div class="mb-2 small">
<span class="text-muted">Quick:</span>
<button type="button" class="btn btn-link btn-sm p-0 me-2" data-days="3">3 days</button>
<button type="button" class="btn btn-link btn-sm p-0 me-2" data-days="7">1 week</button>
<button type="button" class="btn btn-link btn-sm p-0 me-2" data-days="14">2 weeks</button>
<button type="button" class="btn btn-link btn-sm p-0 me-2" data-days="30">1 month</button>
<button type="button" class="btn btn-link btn-sm p-0 text-secondary" data-days="0">clear</button>
</div>

<div class="mb-3">
<label for="log_notes" class="form-label small mb-1">Notes</label>
<textarea class="form-control form-control-sm" id="log_notes" name="notes" rows="3" maxlength="10000"></textarea>
</div>

<button type="submit" class="btn btn-primary btn-sm"><i class="bi bi-check2"></i> Save contact</button>
<span class="text-muted small ms-2" id="removeHint" hidden>This will remove the business from the list (the notes are kept as the reason).</span>
</form>
</div>
</div>
<% End If %>

<div class="card shadow-sm mb-3">
<div class="card-body">
<h2 class="h5 mb-3">History <span class="text-muted fs-6">(<%= interactions.Count %>)</span></h2>
<% If interactions.Count = 0 Then %>
<p class="text-muted mb-0">No contact logged yet.</p>
<% Else %>
<ul class="list-unstyled mb-0">
<% For ix = 0 To interactions.Count - 1
Set it = interactions(ix) %>
<li class="border-start border-3 ps-3 pb-3">
<div class="d-flex flex-wrap gap-2 align-items-center">
<strong><%= Date_Fmt(it("contacted_at")) %></strong>
<span class="badge text-bg-primary"><%= H(Businesses_Label(Businesses_Methods(), it("method"))) %></span>
<% If Len(it("outcome") & "") > 0 Then %><span class="badge text-bg-light border"><%= H(Businesses_Label(Businesses_Outcomes(), it("outcome"))) %></span><% End If %>
<% If Not IsNull(it("follow_up_date")) Then %><span class="small text-muted"><i class="bi bi-arrow-return-right"></i> again on <%= Date_Fmt(it("follow_up_date")) %></span><% End If %>
</div>
<% If Len(it("notes") & "") > 0 Then %><div class="mt-1"><%= Html_Nl2Br(it("notes")) %></div><% End If %>
</li>
<% Next %>
</ul>
<% End If %>
</div>
</div>
</div>

<!-- RIGHT: details -->
<div class="col-lg-5">
<div class="card shadow-sm mb-3">
<div class="card-body">
<h2 class="h5 mb-3">Details</h2>

<div class="mb-3 small">
<% If Len(b("phone") & "") > 0 Then %><div><i class="bi bi-telephone"></i> <a href="tel:<%= H(b("phone")) %>"><%= H(b("phone")) %></a></div><% End If %>
<% If Len(b("email") & "") > 0 Then %><div><i class="bi bi-envelope"></i> <a href="mailto:<%= H(b("email")) %>"><%= H(b("email")) %></a></div><% End If %>
<% If Len(b("website") & "") > 0 Then %><div><i class="bi bi-globe"></i> <a href="<% If LCase(Left(b("website"), 4)) = "http" Then Response.Write H(b("website")) Else Response.Write "https://" & H(b("website")) %>" target="_blank" rel="noopener noreferrer"><%= H(b("website")) %></a></div><% End If %>
<% If Len(b("address1") & "") > 0 Or Len(b("city") & "") > 0 Then %><div><i class="bi bi-geo-alt"></i> <%= H(b("address1")) %><% If Len(b("address1") & "") > 0 And Len(b("city") & "") > 0 Then Response.Write ", " %><%= H(b("city")) %><% If Len(b("state") & "") > 0 Then Response.Write ", " & H(b("state")) %>&nbsp;<%= H(b("zip")) %></div><% End If %>
</div>

<% If Not dup Is Nothing Then %>
<div class="alert alert-warning small">
<i class="bi bi-exclamation-triangle"></i>
Nothing was saved yet. The <%= dup("matched") %> you entered is already used by
<a href="/businesses/<%= dup("id") %>" target="_blank" rel="noopener"><%= H(dup("name")) %></a>.
Fix it, or press <strong>Save anyway</strong> to keep both.
</div>
<% End If %>

<form method="post" action="/businesses/<%= bid %>/update">
<input type="hidden" name="csrf" value="<%= H(csrf) %>" />
<% If Not dup Is Nothing Then %><input type="hidden" name="allow_duplicate" value="1" /><% End If %>

<div class="mb-2">
<label class="form-label small mb-1" for="f_name">Business name</label>
<input type="text" class="form-control form-control-sm" id="f_name" name="name" value="<%= H(fv("name")) %>" maxlength="255" required />
</div>
<div class="mb-2">
<label class="form-label small mb-1" for="f_contact">Contact</label>
<input type="text" class="form-control form-control-sm" id="f_contact" name="contact_name" value="<%= H(fv("contact_name")) %>" maxlength="150" />
</div>
<div class="row g-2 mb-2">
<div class="col-6">
<label class="form-label small mb-1" for="f_phone">Phone</label>
<input type="text" class="form-control form-control-sm" id="f_phone" name="phone" value="<%= H(fv("phone")) %>" maxlength="40" />
</div>
<div class="col-6">
<label class="form-label small mb-1" for="f_email">Email</label>
<input type="text" class="form-control form-control-sm" id="f_email" name="email" value="<%= H(fv("email")) %>" maxlength="255" />
</div>
</div>
<div class="mb-2">
<label class="form-label small mb-1" for="f_web">Website</label>
<input type="text" class="form-control form-control-sm" id="f_web" name="website" value="<%= H(fv("website")) %>" maxlength="255" />
</div>
<div class="mb-2">
<label class="form-label small mb-1" for="f_addr">Address</label>
<input type="text" class="form-control form-control-sm" id="f_addr" name="address1" value="<%= H(fv("address1")) %>" maxlength="255" />
</div>
<div class="row g-2 mb-2">
<div class="col-5"><label class="form-label small mb-1" for="f_city">City</label><input type="text" class="form-control form-control-sm" id="f_city" name="city" value="<%= H(fv("city")) %>" maxlength="100" /></div>
<div class="col-3"><label class="form-label small mb-1" for="f_state">State</label><input type="text" class="form-control form-control-sm" id="f_state" name="state" value="<%= H(fv("state")) %>" maxlength="50" /></div>
<div class="col-4"><label class="form-label small mb-1" for="f_zip">Zip</label><input type="text" class="form-control form-control-sm" id="f_zip" name="zip" value="<%= H(fv("zip")) %>" maxlength="20" /></div>
</div>
<div class="row g-2 mb-2">
<div class="col-6">
<label class="form-label small mb-1" for="f_ind">Industry</label>
<select class="form-select form-select-sm" id="f_ind" name="industry_id">
<option value="">(none)</option>
<% For Each indKey2 In industries.Keys %>
<option value="<%= indKey2 %>"<% If CStr(fv("industry_id") & "") = indKey2 Then Response.Write " selected" %>><%= H(industries(indKey2)) %></option>
<% Next %>
</select>
</div>
<div class="col-6">
<label class="form-label small mb-1" for="f_indnew">&hellip;or add new</label>
<input type="text" class="form-control form-control-sm" id="f_indnew" name="industry_new" maxlength="100" value="<% If fv.Exists("_industry_new") Then Response.Write H(fv("_industry_new")) %>" />
</div>
</div>
<div class="row g-2 mb-2 align-items-end">
<div class="col-6">
<div class="form-check">
<input class="form-check-input" type="checkbox" id="f_cust" name="is_customer" value="1"<% If fv("is_customer") & "" = "1" Then Response.Write " checked" %> />
<label class="form-check-label small" for="f_cust">Previous customer</label>
</div>
</div>
<div class="col-6">
<label class="form-label small mb-1" for="f_first">First order</label>
<input type="date" class="form-control form-control-sm" id="f_first" name="first_order_date" value="<%= Date_Iso(fv("first_order_date")) %>" />
</div>
</div>
<div class="mb-3">
<label class="form-label small mb-1" for="f_notes">Notes <span class="text-muted">(other people, anything else)</span></label>
<textarea class="form-control form-control-sm" id="f_notes" name="notes" rows="4" maxlength="10000"><%= H(fv("notes")) %></textarea>
</div>
<button type="submit" class="btn <% If dup Is Nothing Then Response.Write "btn-outline-primary" Else Response.Write "btn-warning" %> btn-sm"><% If dup Is Nothing Then Response.Write "Save details" Else Response.Write "Save anyway" %></button>
</form>
</div>
</div>

<% If Not isRemoved Then %>
<div class="card border-danger-subtle shadow-sm mb-3">
<div class="card-body">
<h2 class="h6 text-danger">Remove from list</h2>
<form method="post" action="/businesses/<%= bid %>/remove" class="d-flex gap-2">
<input type="hidden" name="csrf" value="<%= H(csrf) %>" />
<input type="text" class="form-control form-control-sm" name="reason" placeholder="Reason (optional)" maxlength="255" />
<button type="submit" class="btn btn-outline-danger btn-sm text-nowrap">Remove</button>
</form>
<div class="form-text">Removed businesses are hidden from the list and won't be re-added by an import. You can restore them.</div>
</div>
</div>
<% End If %>

<p class="text-muted small">
Added <%= Date_Fmt(b("created_at")) %><% If Not IsNull(b("import_batch_id")) Then Response.Write " &middot; import batch #" & b("import_batch_id") %>
<% If Len(b("source") & "") > 0 Then %>&middot; <%= H(b("source")) %><% End If %>
</p>
</div>
</div>

<script>
(function () {
var fu = document.getElementById('follow_up_date');
document.querySelectorAll('[data-days]').forEach(function (btn) {
btn.addEventListener('click', function () {
var n = parseInt(btn.getAttribute('data-days'), 10);
if (!fu) return;
if (n === 0) { fu.value = ''; return; }
var d = new Date(); d.setDate(d.getDate() + n);
var m = ('0' + (d.getMonth() + 1)).slice(-2), day = ('0' + d.getDate()).slice(-2);
fu.value = d.getFullYear() + '-' + m + '-' + day;
});
});
var oc = document.getElementById('outcome'), hint = document.getElementById('removeHint');
if (oc && hint) oc.addEventListener('change', function () { hint.hidden = (oc.value !== 'remove'); });
})();
</script>

+ 192
- 0
app/views/Dashboard/index.asp Näytä tiedosto

@@ -0,0 +1,192 @@
<%
' Tile helper values: label, number, link, optional emphasis class
Dim tiles, ti, t, pct, pctText, barW, di, dd, barPct, oi, ob, mi, mb, ii, ir, bi_
tiles = Array( _
Array("Prospects", counts("prospects"), "/businesses?show=prospects", ""), _
Array("Previous customers", counts("customers"), "/businesses?show=customers", "text-success"), _
Array("Never contacted", counts("never_contacted"), "/businesses?show=prospects&contacted=never", ""), _
Array("Follow-ups overdue", counts("overdue"), "/", Iif_(counts("overdue") > 0, "text-danger", "")), _
Array("Due today", counts("due_today"), "/", Iif_(counts("due_today") > 0, "text-warning-emphasis", "")), _
Array("Due in the next 7 days", counts("this_week"), "/", ""), _
Array("No phone number", counts("no_phone"), "/businesses?show=prospects", "text-muted"), _
Array("Removed", counts("removed"), "/businesses?status=removed", "text-muted") _
)
%>
<% Flash().ShowErrorsIfPresent : Flash().ShowSuccessIfPresent %>

<div class="d-flex justify-content-between align-items-center mb-3">
<div>
<h1 class="h3 mb-0">Dashboard</h1>
<div class="text-muted small"><%= FormatNumber(counts("active"), 0) %> active businesses &middot; <%= FormatNumber(counts("total"), 0) %> including removed</div>
</div>
</div>

<!-- The list -->
<div class="row g-3 mb-4">
<% For ti = 0 To UBound(tiles)
t = tiles(ti) %>
<div class="col-6 col-md-3">
<a href="<%= t(2) %>" class="card shadow-sm text-decoration-none h-100">
<div class="card-body py-3">
<div class="display-6 fw-semibold <%= t(3) %>"><%= FormatNumber(t(1), 0) %></div>
<div class="small text-muted"><%= t(0) %></div>
</div>
</a>
</div>
<% Next %>
</div>

<div class="row g-3 mb-4">
<!-- Pipeline -->
<div class="col-lg-5">
<div class="card shadow-sm h-100">
<div class="card-body">
<h2 class="h5 mb-3">Where everyone stands</h2>
<%
Dim stages, si, s, tot
stages = Array(Array("New", counts("st_new"), "text-bg-secondary", "new"), Array("Contacted", counts("st_contacted"), "text-bg-info", "contacted"), Array("Follow-up", counts("st_follow_up"), "text-bg-warning", "follow_up"))
tot = counts("st_new") + counts("st_contacted") + counts("st_follow_up")
If tot = 0 Then tot = 1
%>
<div class="progress mb-3" style="height: 1.5rem;" role="img" aria-label="Pipeline breakdown">
<% For si = 0 To UBound(stages)
s = stages(si)
If s(1) > 0 Then %>
<div class="progress-bar <%= s(2) %>" style="width: <%= Round(s(1) * 100 / tot, 1) %>%"><%= s(0) %></div>
<% End If
Next %>
</div>
<table class="table table-sm mb-0">
<% For si = 0 To UBound(stages)
s = stages(si) %>
<tr>
<td><span class="badge <%= s(2) %>"><%= s(0) %></span></td>
<td class="text-end"><a href="/businesses?status=<%= s(3) %>" class="text-decoration-none"><%= FormatNumber(s(1), 0) %></a></td>
<td class="text-end text-muted small"><%= Round(s(1) * 100 / tot, 0) %>%</td>
</tr>
<% Next %>
</table>
<div class="form-text">Counts include previous customers. Removed businesses are not counted here.</div>
</div>
</div>
</div>

<!-- Activity -->
<div class="col-lg-7">
<div class="card shadow-sm h-100">
<div class="card-body">
<h2 class="h5 mb-3">Contact activity</h2>
<div class="row text-center mb-3">
<div class="col-4"><div class="h3 mb-0"><%= FormatNumber(activity("today"), 0) %></div><div class="small text-muted">Today</div></div>
<div class="col-4"><div class="h3 mb-0"><%= FormatNumber(activity("week"), 0) %></div><div class="small text-muted">Last 7 days</div></div>
<div class="col-4"><div class="h3 mb-0"><%= FormatNumber(activity("month"), 0) %></div><div class="small text-muted">Last 30 days</div></div>
</div>

<div class="small text-muted mb-1">Last 14 days</div>
<div class="d-flex align-items-end gap-1" style="height: 90px;" role="img" aria-label="Contacts per day for the last 14 days">
<% For di = 0 To daily.Count - 1
dd = daily(di)
barPct = Round(dd(1) * 100 / maxDaily, 0)
If dd(1) > 0 And barPct < 6 Then barPct = 6 %>
<div class="flex-fill d-flex flex-column justify-content-end align-items-center h-100" title="<%= Date_Fmt(dd(0)) %>: <%= dd(1) %>">
<div class="small text-muted" style="font-size: .7rem;"><% If dd(1) > 0 Then Response.Write dd(1) %></div>
<div class="w-100 rounded-top <% If dd(0) = Date Then Response.Write "bg-primary" Else Response.Write "bg-primary-subtle" %>" style="height: <%= barPct %>%; min-height: <% If dd(1) > 0 Then Response.Write "2px" Else Response.Write "1px" %>;<% If dd(1) = 0 Then Response.Write " background:#dee2e6;" %>"></div>
</div>
<% Next %>
</div>
<div class="d-flex gap-1 small text-muted" style="font-size: .7rem;">
<% For di = 0 To daily.Count - 1 %>
<div class="flex-fill text-center"><%= Day(daily(di)(0)) %></div>
<% Next %>
</div>
</div>
</div>
</div>
</div>

<div class="row g-3 mb-4">
<div class="col-md-6">
<div class="card shadow-sm h-100">
<div class="card-body">
<h2 class="h5 mb-3">How you reached out <span class="text-muted fs-6">(30 days)</span></h2>
<% If byMethod.Count = 0 Then %><p class="text-muted mb-0">Nothing logged yet.</p><% Else %>
<table class="table table-sm mb-0">
<% For mi = 0 To byMethod.Count - 1
mb = byMethod(mi) %>
<tr><td><%= H(Businesses_Label(Businesses_Methods(), mb(0))) %></td><td class="text-end"><%= FormatNumber(mb(1), 0) %></td></tr>
<% Next %>
</table>
<% End If %>
</div>
</div>
</div>
<div class="col-md-6">
<div class="card shadow-sm h-100">
<div class="card-body">
<h2 class="h5 mb-3">Outcomes <span class="text-muted fs-6">(30 days)</span></h2>
<% If byOutcome.Count = 0 Then %><p class="text-muted mb-0">Nothing logged yet.</p><% Else %>
<table class="table table-sm mb-0">
<% For oi = 0 To byOutcome.Count - 1
ob = byOutcome(oi) %>
<tr>
<td><% If Len(ob(0)) = 0 Then Response.Write "<span class=""text-muted"">(no outcome)</span>" Else Response.Write H(Businesses_Label(Businesses_Outcomes(), ob(0))) %></td>
<td class="text-end"><%= FormatNumber(ob(1), 0) %></td>
</tr>
<% Next %>
</table>
<% End If %>
</div>
</div>
</div>
</div>

<div class="row g-3 mb-4">
<div class="col-lg-7">
<div class="card shadow-sm h-100">
<div class="card-body">
<h2 class="h5 mb-3">Biggest industries <span class="text-muted fs-6">(<a href="/industries" class="text-decoration-none">manage</a>)</span></h2>
<% If industries.Count = 0 Then %><p class="text-muted mb-0">No industries yet.</p><% Else %>
<table class="table table-sm align-middle mb-0">
<thead><tr><th>Industry</th><th class="text-end">Businesses</th><th style="width:40%">Contacted</th></tr></thead>
<tbody>
<% For ii = 0 To industries.Count - 1
ir = industries(ii)
If ir(2) > 0 Then pct = Round(ir(3) * 100 / ir(2), 0) Else pct = 0
If ir(3) > 0 And pct = 0 Then pctText = "&lt;1" Else pctText = CStr(pct)
If ir(3) > 0 And pct = 0 Then barW = 1 Else barW = pct %>
<tr>
<td><a href="/businesses?industry=<%= ir(0) %>" class="text-decoration-none"><%= H(ir(1)) %></a></td>
<td class="text-end"><%= FormatNumber(ir(2), 0) %></td>
<td>
<div class="d-flex align-items-center gap-2">
<div class="progress flex-fill" style="height: .6rem;" role="img" aria-label="<%= pctText %> percent contacted"><div class="progress-bar" style="width: <%= barW %>%"></div></div>
<span class="small text-muted text-nowrap"><%= FormatNumber(ir(3), 0) %> &middot; <%= pctText %>%</span>
</div>
</td>
</tr>
<% Next %>
</tbody>
</table>
<% End If %>
</div>
</div>
</div>
<div class="col-lg-5">
<div class="card shadow-sm h-100">
<div class="card-body">
<h2 class="h5 mb-3">Recent imports <span class="text-muted fs-6">(<a href="/import" class="text-decoration-none">import</a>)</span></h2>
<% If imports.Count = 0 Then %><p class="text-muted mb-0">No imports yet.</p><% Else %>
<ul class="list-unstyled mb-0 small">
<% For bi_ = 0 To imports.Count - 1
ir = imports(bi_) %>
<li class="mb-2">
<div class="fw-semibold text-break"><%= H(ir(1)) %></div>
<div class="text-muted"><%= Date_Fmt(ir(2)) %> &middot; <%= FormatNumber(ir(4), 0) %> added of <%= FormatNumber(ir(3), 0) %> rows</div>
</li>
<% Next %>
</ul>
<% End If %>
</div>
</div>
</div>
</div>

+ 55
- 0
app/views/Error/NotFound.asp Näytä tiedosto

@@ -0,0 +1,55 @@
<div class="main-content">
<div class="d-flex align-items-center justify-content-center min-vh-100 bg-light">
<div class="card shadow-sm border-0 text-center p-4 p-md-5 error-card">
<div class="mb-3">
<i class="bi bi-exclamation-triangle-fill display-3 text-warning"></i>
</div>
<h1 class="h3 mb-3">404 - Page Not Found</h1>
<p class="text-muted mb-3">
The page you’re looking for could not be found. It may have been moved, deleted,
or the address might be incorrect.
</p>
<%
Dim redirectSeconds : redirectSeconds = GetAppSetting("Error404RedirectSeconds")
If redirectSeconds = "nothing" Or Not IsNumeric(redirectSeconds) Then redirectSeconds = 5
%>
<p class="text-muted mb-3">
You'll be redirected to the homepage in
<span id="countdown"><%= redirectSeconds %></span> seconds.
</p>
<a href="/" class="btn btn-primary mt-2">
Go to Homepage Now
</a>
</div>
</div>
</div>

<style>
.error-card {
max-width: 540px;
border-radius: 1rem;
}

.error-card .bi {
line-height: 1;
}
</style>

<script>
(function () {
let seconds = <%= redirectSeconds %>;
const countdown = document.getElementById('countdown');

const timer = setInterval(function () {
seconds--;
if (countdown) {
countdown.textContent = seconds;
}

if (seconds <= 0) {
clearInterval(timer);
window.location.href = '/';
}
}, 1000);
})();
</script>

+ 85
- 0
app/views/Home/index.asp Näytä tiedosto

@@ -0,0 +1,85 @@


<div class="row mb-4">
<div class="col-lg-8">
<div class="card shadow-sm mb-3">
<div class="card-body">
<h1 class="h3 mb-3">Welcome to RouteKit Classic ASP</h1>
<p class="text-muted">
Your lightweight, opinionated MVC-style framework for Classic ASP.
</p>
<p>
This <code>Home.Index</code> view is using the shared
<code>Header.asp</code> and <code>Footer.asp</code> layout files.
</p>
<p class="mb-0">
Start by wiring up your controllers, repositories, and views — this page is just a
friendly placeholder so you know everything is hooked up correctly.
</p>
</div>
</div>
</div>

<div class="col-lg-4">
<div class="card border-0 bg-light mb-3">
<div class="card-body">
<h2 class="h5 mb-3">Quick info</h2>
<ul class="list-unstyled mb-0 small">
<li class="mb-1">
<strong>View:</strong>
<code>app/Views/Home.Index.asp</code>
</li>
<li class="mb-1">
<strong>Layout:</strong>
<code>Shared/Header.asp</code> &amp; <code>Shared/Footer.asp</code>
</li>
<li class="mb-1">
<strong>Default route:</strong>
typically <code>/Home/Index</code> or <code>/</code> via the dispatcher.
</li>
</ul>
</div>
</div>
</div>
</div>

<div class="row gy-3">
<div class="col-md-4">
<div class="card h-100 shadow-sm">
<div class="card-body">
<h2 class="h5">Next step: Controllers</h2>
<p class="small text-muted">
Use your <code>generateController.vbs</code> script to scaffold new controllers.
</p>
<pre class="small mb-0"><code>cscript //nologo Scripts\generateController.vbs ^
Home "Index"</code></pre>
</div>
</div>
</div>

<div class="col-md-4">
<div class="card h-100 shadow-sm">
<div class="card-body">
<h2 class="h5">POBO &amp; Repository</h2>
<p class="small text-muted">
Generate strongly-typed POBOs and repositories from your Access/SQL schema.
</p>
<pre class="small mb-0"><code>cscript //nologo Scripts\GenerateRepo.vbs ^
/table:Users /pk:UserId</code></pre>
</div>
</div>
</div>

<div class="col-md-4">
<div class="card h-100 shadow-sm">
<div class="card-body">
<h2 class="h5">Where to put stuff</h2>
<ul class="small mb-0">
<li><code>/core/</code> – framework libs (DAL, routing, helpers)</li>
<li><code>/app/Views/</code> – pages like this one</li>
<li><code>/public/</code> – IIS root (Default.asp, web.config)</li>
</ul>
</div>
</div>
</div>
</div>

+ 34
- 0
app/views/Import/index.asp Näytä tiedosto

@@ -0,0 +1,34 @@
<% Flash().ShowErrorsIfPresent : Flash().ShowSuccessIfPresent %>

<div class="row">
<div class="col-lg-8">
<div class="card shadow-sm mb-3">
<div class="card-body">
<h1 class="h3 mb-3">Import businesses</h1>
<p class="text-muted">
Upload an Excel (<code>.xlsx</code>, <code>.xls</code>) or <code>.csv</code> file. The first row must be the column headings.
You'll match the columns to fields on the next step before anything is saved.
</p>

<form method="post" action="/import/upload" enctype="multipart/form-data">
<input type="hidden" name="csrf" value="<%= H(csrf) %>" />
<div class="mb-3">
<label for="file" class="form-label">File</label>
<input class="form-control" type="file" id="file" name="file" accept=".csv,.xlsx,.xls" required />
</div>
<button type="submit" class="btn btn-primary"><i class="bi bi-upload"></i> Upload and map columns</button>
</form>
</div>
</div>
</div>

<div class="col-lg-4">
<div class="card border-0 bg-light">
<div class="card-body small">
<h2 class="h6">How duplicates are handled</h2>
<p class="mb-2">A row is skipped when its <strong>phone number</strong> (digits only) or its <strong>email address</strong> already exists, either in the database or earlier in the same file.</p>
<p class="mb-0">Rows with no business name are skipped. New industries found in the file are created automatically.</p>
</div>
</div>
</div>
</div>

+ 86
- 0
app/views/Import/map.asp Näytä tiedosto

@@ -0,0 +1,86 @@
<div class="card shadow-sm mb-3">
<div class="card-body">
<h1 class="h3 mb-1">Match columns</h1>
<p class="text-muted">
<i class="bi bi-file-earmark-spreadsheet"></i> <%= H(originalName) %> &middot;
Choose what each column contains. Columns set to <em>Ignore</em> are not imported. Sample values come from the first rows of the file.
</p>

<form method="post" action="/import/run" id="mapForm">
<input type="hidden" name="csrf" value="<%= H(csrf) %>" />
<input type="hidden" name="token" value="<%= H(token) %>" />
<input type="hidden" name="original_name" value="<%= H(originalName) %>" />
<input type="hidden" name="ncols" value="<%= UBound(headers) + 1 %>" />

<div class="table-responsive">
<table class="table table-sm align-middle">
<thead>
<tr><th>Column in file</th><th>Import as</th><th>Sample values</th></tr>
</thead>
<tbody>
<%
Dim ci, ri, guess, fld, sample, usedGuess
Set usedGuess = CreateObject("Scripting.Dictionary")
For ci = 0 To UBound(headers)
guess = ImportFile_GuessField(headers(ci))
' Only the first column guessed for a field is pre-selected.
If Len(guess) > 0 Then
If usedGuess.Exists(guess) Then guess = "" Else usedGuess.Add guess, 1
End If
%>
<tr>
<td class="fw-semibold"><%= H(headers(ci)) %></td>
<td>
<select name="map_<%= ci %>" class="form-select form-select-sm">
<option value="">Ignore</option>
<% For Each fld In fields %>
<option value="<%= fld(0) %>"<% If fld(0) = guess Then Response.Write " selected" %>><%= H(fld(1)) %></option>
<% Next %>
</select>
</td>
<td class="text-muted small">
<%
sample = ""
For ri = 0 To rows.Count - 1
If Len(ImportFile_Cell(rows(ri), ci)) > 0 Then
If Len(sample) > 0 Then sample = sample & " &middot; "
sample = sample & H(Left(ImportFile_Cell(rows(ri), ci), 40))
End If
Next
Response.Write sample
%>
</td>
</tr>
<% Next %>
</tbody>
</table>
</div>

<div class="row g-3 mb-3">
<div class="col-md-6">
<label for="default_industry" class="form-label">Default industry <span class="text-muted">(used when a row has none)</span></label>
<input type="text" class="form-control" id="default_industry" name="default_industry" maxlength="100" />
</div>
<div class="col-md-6 d-flex align-items-end">
<div class="form-check">
<input class="form-check-input" type="checkbox" id="mark_customers" name="mark_customers" value="1" />
<label class="form-check-label" for="mark_customers">These are previous customers</label>
</div>
</div>
</div>

<button type="submit" class="btn btn-primary" id="runBtn"><i class="bi bi-check2-circle"></i> Import</button>
<a href="/import" class="btn btn-link">Cancel</a>
<span class="text-muted small ms-2 d-none" id="working">Importing &mdash; large files can take a minute&hellip;</span>
</form>
</div>
</div>

<script>
document.getElementById('mapForm').addEventListener('submit', function (e) {
var hasName = Array.prototype.some.call(this.querySelectorAll('select'), function (s) { return s.value === 'name'; });
if (!hasName) { e.preventDefault(); alert('Map one column to "Business name".'); return; }
document.getElementById('runBtn').disabled = true;
document.getElementById('working').classList.remove('d-none');
});
</script>

+ 43
- 0
app/views/Import/result.asp Näytä tiedosto

@@ -0,0 +1,43 @@
<% If res("failed") Then %>
<div class="alert alert-danger">
<strong>Import failed &mdash; nothing was saved.</strong><br />
<%= H(res("error")) %>
</div>
<p><a href="/import" class="btn btn-primary">Start over</a></p>
<% Else %>
<div class="card shadow-sm mb-3">
<div class="card-body">
<h1 class="h3 mb-3"><i class="bi bi-check-circle text-success"></i> Import complete</h1>
<p class="text-muted"><%= H(originalName) %></p>

<div class="row text-center g-3 mb-3">
<div class="col-6 col-md-3"><div class="border rounded p-3"><div class="display-6"><%= res("read") %></div><div class="small text-muted">Rows read</div></div></div>
<div class="col-6 col-md-3"><div class="border rounded p-3 border-success"><div class="display-6 text-success"><%= res("added") %></div><div class="small text-muted">Added</div></div></div>
<div class="col-6 col-md-3"><div class="border rounded p-3"><div class="display-6"><%= res("dup_db") + res("dup_file") %></div><div class="small text-muted">Duplicates skipped</div></div></div>
<div class="col-6 col-md-3"><div class="border rounded p-3"><div class="display-6"><%= res("no_name") %></div><div class="small text-muted">No name</div></div></div>
</div>

<ul class="small text-muted">
<li><%= res("dup_db") %> already in the database, <%= res("dup_file") %> repeated within this file.</li>
<li><%= res("new_industries") %> new industries created.</li>
<% If markCustomers Then %><li>All added rows were flagged as previous customers.</li><% End If %>
<li>Import batch #<%= res("batch_id") %></li>
</ul>

<% If res("dup_db") + res("dup_file") > 0 Then %>
<h2 class="h6 mt-4">Skipped duplicates<% If res("dup_db") + res("dup_file") > res("dups").Count Then Response.Write " (first " & res("dups").Count & ")" %></h2>
<table class="table table-sm small">
<thead><tr><th>File row</th><th>Business</th><th>Matched on</th></tr></thead>
<tbody>
<% Dim dupList, di, d : Set dupList = res("dups") %>
<% For di = 0 To dupList.Count - 1 : d = dupList(di) %>
<tr><td><%= d(0) %></td><td><%= H(d(1)) %></td><td><%= d(2) %></td></tr>
<% Next %>
</tbody>
</table>
<% End If %>

<a href="/import" class="btn btn-primary">Import another file</a>
</div>
</div>
<% End If %>

+ 86
- 0
app/views/Industries/index.asp Näytä tiedosto

@@ -0,0 +1,86 @@
<% Flash().ShowErrorsIfPresent : Flash().ShowSuccessIfPresent %>

<div class="d-flex justify-content-between align-items-center mb-3">
<h1 class="h3 mb-0">Industries</h1>
<span class="text-muted small"><%= list.Count %> industries</span>
</div>

<form method="post" action="/industries/create" class="card shadow-sm mb-3">
<div class="card-body">
<div class="row g-2 align-items-end">
<div class="col-md-6">
<label for="newName" class="form-label small mb-1">Add an industry</label>
<input type="text" class="form-control form-control-sm" id="newName" name="name" maxlength="100" required />
</div>
<div class="col-md-3">
<input type="hidden" name="csrf" value="<%= H(csrf) %>" />
<button type="submit" class="btn btn-primary btn-sm">Add</button>
</div>
</div>
</div>
</form>

<div class="card shadow-sm mb-3">
<div class="table-responsive">
<table class="table table-sm align-middle mb-0">
<thead class="table-light">
<tr><th style="width:34%">Name</th><th class="text-end" style="width:8%">Businesses</th><th>Rename</th><th>Merge into&hellip;</th><th></th></tr>
</thead>
<tbody>
<% Dim ii, row, oi
For ii = 0 To list.Count - 1
Set row = list(ii)
%>
<tr>
<td class="fw-semibold"><%= H(row("name")) %></td>
<td class="text-end"><a href="/businesses?industry=<%= row("id") %>&amp;status=all" class="text-decoration-none"><%= FormatNumber(row("n"), 0) %></a></td>
<td>
<form method="post" action="/industries/<%= row("id") %>/rename" class="d-flex gap-1">
<input type="hidden" name="csrf" value="<%= H(csrf) %>" />
<input type="text" class="form-control form-control-sm" name="name" value="<%= H(row("name")) %>" maxlength="100" aria-label="New name for <%= H(row("name")) %>" />
<button type="submit" class="btn btn-outline-secondary btn-sm">Save</button>
</form>
</td>
<td>
<form method="post" action="/industries/<%= row("id") %>/merge" class="d-flex gap-1 js-confirm" data-confirm="Merge &quot;<%= H(row("name")) %>&quot; into the selected industry? This can't be undone.">
<input type="hidden" name="csrf" value="<%= H(csrf) %>" />
<select class="form-select form-select-sm" name="target_id" required aria-label="Merge <%= H(row("name")) %> into">
<option value="">Choose&hellip;</option>
<% For oi = 0 To list.Count - 1
If list(oi)("id") <> row("id") Then %>
<option value="<%= list(oi)("id") %>"><%= H(list(oi)("name")) %></option>
<% End If
Next %>
</select>
<button type="submit" class="btn btn-outline-warning btn-sm">Merge</button>
</form>
</td>
<td class="text-end">
<% If row("n") = 0 Then %>
<form method="post" action="/industries/<%= row("id") %>/delete" class="d-inline js-confirm" data-confirm="Delete &quot;<%= H(row("name")) %>&quot;?">
<input type="hidden" name="csrf" value="<%= H(csrf) %>" />
<button type="submit" class="btn btn-outline-danger btn-sm">Delete</button>
</form>
<% End If %>
</td>
</tr>
<% Next %>
<% If uncategorized > 0 Then %>
<tr class="table-light">
<td class="fst-italic text-muted">(No industry)</td>
<td class="text-end"><a href="/businesses?industry=0&amp;status=all" class="text-decoration-none"><%= FormatNumber(uncategorized, 0) %></a></td>
<td colspan="3"></td>
</tr>
<% End If %>
</tbody>
</table>
</div>
</div>

<script>
document.querySelectorAll('form.js-confirm').forEach(function (f) {
f.addEventListener('submit', function (e) {
if (!window.confirm(f.getAttribute('data-confirm'))) e.preventDefault();
});
});
</script>

+ 77
- 0
app/views/Today/index.asp Näytä tiedosto

@@ -0,0 +1,77 @@
<% Flash().ShowErrorsIfPresent : Flash().ShowSuccessIfPresent %>

<div class="d-flex justify-content-between align-items-center mb-3">
<div>
<h1 class="h3 mb-0">Today</h1>
<div class="text-muted small"><%= WeekdayName(Weekday(Date)) %>, <%= Date_Fmt(Date) %></div>
</div>
<a href="/businesses?contacted=never&amp;show=prospects" class="btn btn-outline-primary btn-sm"><i class="bi bi-telephone-plus"></i> Find someone new to contact</a>
</div>

<% If overdue.Count = 0 And dueToday.Count = 0 Then %>
<div class="alert alert-success">
<i class="bi bi-check-circle"></i> You're all caught up &mdash; nothing is due.
<% If upcoming.Count > 0 Then %>There <% If upcoming.Count = 1 Then Response.Write "is 1 follow-up" Else Response.Write "are " & upcoming.Count & " follow-ups" %> coming up this week.<% End If %>
</div>
<% End If %>

<%
Dim groups(2), gi, g, gname, gclass, items, ri, rr, daysLate, lastLine
Set groups(0) = overdue : Set groups(1) = dueToday : Set groups(2) = upcoming
For gi = 0 To 2
Set items = groups(gi)
If items.Count > 0 Then
Select Case gi
Case 0: gname = "Overdue" : gclass = "text-danger"
Case 1: gname = "Due today" : gclass = "text-warning-emphasis"
Case 2: gname = "Coming up (next 7 days)" : gclass = "text-secondary"
End Select
%>
<h2 class="h5 mt-4 <%= gclass %>"><%= gname %> <span class="badge text-bg-light border"><%= items.Count %></span></h2>
<div class="card shadow-sm mb-3">
<div class="list-group list-group-flush">
<% For ri = 0 To items.Count - 1
Set rr = items(ri)
daysLate = DateDiff("d", CDate(rr("next_action_date")), Date)
%>
<div class="list-group-item">
<div class="row g-2 align-items-center">
<div class="col-md-5">
<a class="fw-semibold text-decoration-none" href="/businesses/<%= rr("id") %>"><%= H(rr("name")) %></a>
<% If rr("is_customer") = 1 Then %><span class="badge text-bg-success ms-1">Customer</span><% End If %>
<div class="small text-muted">
<%= H(rr("industry_name")) %>
<% If Len(rr("city") & "") > 0 Then %><% If Len(rr("industry_name") & "") > 0 Then Response.Write " &middot; " %><%= H(rr("city")) %><% End If %>
<% If Len(rr("contact_name") & "") > 0 Then %> &middot; <%= H(rr("contact_name")) %><% End If %>
</div>
</div>
<div class="col-md-3 small">
<% If Len(rr("phone") & "") > 0 Then %><div><i class="bi bi-telephone"></i> <a href="tel:<%= H(rr("phone")) %>" class="text-decoration-none"><%= H(rr("phone")) %></a></div><% End If %>
<% If Len(rr("email") & "") > 0 Then %><div class="text-truncate"><i class="bi bi-envelope"></i> <a href="mailto:<%= H(rr("email")) %>" class="text-decoration-none"><%= H(rr("email")) %></a></div><% End If %>
</div>
<div class="col-md-2 small">
<span class="<%= gclass %> fw-semibold"><%= Date_Fmt(rr("next_action_date")) %></span>
<% If daysLate > 0 Then %><div class="text-danger"><%= daysLate %> day<% If daysLate <> 1 Then Response.Write "s" %> late</div>
<% ElseIf daysLate < 0 Then %><div class="text-muted">in <%= -daysLate %> day<% If daysLate <> -1 Then Response.Write "s" %></div><% End If %>
</div>
<div class="col-md-2 text-md-end">
<a href="/businesses/<%= rr("id") %>" class="btn btn-primary btn-sm">Open</a>
</div>
</div>
<% If Len(rr("last_method") & "") > 0 Then
lastLine = Businesses_Label(Businesses_Methods(), rr("last_method"))
If Len(rr("last_outcome") & "") > 0 Then lastLine = lastLine & " &ndash; " & H(Businesses_Label(Businesses_Outcomes(), rr("last_outcome")))
%>
<div class="small text-muted mt-1">
Last: <%= Date_Fmt(rr("last_contacted_at")) %> &middot; <%= lastLine %>
<% If Len(rr("last_notes") & "") > 0 Then %>&nbsp;&mdash; <em><%= H(Left(Replace(Replace(rr("last_notes"), vbCr, " "), vbLf, " "), 140)) %><% If Len(rr("last_notes")) > 140 Then Response.Write "&hellip;" %></em><% End If %>
</div>
<% End If %>
</div>
<% Next %>
</div>
</div>
<%
End If
Next
%>

+ 8
- 0
app/views/shared/footer.asp Näytä tiedosto

@@ -0,0 +1,8 @@
</div>
</main>

<!-- Bootstrap bundle (with Popper) -->
<script src="https://cdn.jsdelivr.net/npm/bootstrap@5.3.3/dist/js/bootstrap.bundle.min.js"></script>

</body>
</html>

+ 86
- 0
app/views/shared/header.asp Näytä tiedosto

@@ -0,0 +1,86 @@
<!doctype html>
<%
Response.Charset = "utf-8"
Response.CodePage = 65001

' Safe title resolution
Dim pageTitle
If IsObject(CurrentController) Then
On Error Resume Next
pageTitle = CurrentController.Title
If Err.Number <> 0 Then
pageTitle = "RouteKit Classic ASP"
Err.Clear
End If
On Error GoTo 0
End If

If Len(pageTitle) = 0 Then pageTitle = "Classic ASP Starter Template"
%>
<html lang="en">
<head>
<meta charset="utf-8" />
<title><%= pageTitle %></title>
<meta name="viewport" content="width=device-width, initial-scale=1" />

<!-- Bootstrap CSS -->
<link href="https://cdn.jsdelivr.net/npm/bootstrap@5.3.3/dist/css/bootstrap.min.css" rel="stylesheet" />
<!-- Bootstrap Icons (optional) -->
<link href="https://cdn.jsdelivr.net/npm/bootstrap-icons@1.11.3/font/bootstrap-icons.css" rel="stylesheet" />

<!-- App CSS -->
<link href="/css/site.css" rel="stylesheet" />

<style>
body {
background-color: #f5f5f5;
}
.rk-navbar-brand {
font-weight: 600;
letter-spacing: 0.03em;
}
main.routekit-main {
padding-top: 1.5rem;
padding-bottom: 2rem;
}
</style>
</head>
<body>
<!-- Top navbar -->
<nav class="navbar navbar-expand-lg navbar-dark bg-dark">
<div class="container-fluid">
<a class="navbar-brand rk-navbar-brand" href="/">
Prospecting
</a>

<button class="navbar-toggler" type="button" data-bs-toggle="collapse" data-bs-target="#rkMainNav" aria-controls="rkMainNav" aria-expanded="false" aria-label="Toggle navigation">
<span class="navbar-toggler-icon"></span>
</button>

<div class="collapse navbar-collapse" id="rkMainNav">
<ul class="navbar-nav me-auto mb-2 mb-lg-0">
<li class="nav-item">
<a class="nav-link" href="/">Today</a>
</li>
<li class="nav-item">
<a class="nav-link" href="/businesses">Businesses</a>
</li>
<li class="nav-item">
<a class="nav-link" href="/industries">Industries</a>
</li>
<li class="nav-item">
<a class="nav-link" href="/dashboard">Dashboard</a>
</li>
<li class="nav-item">
<a class="nav-link" href="/import">Import</a>
</li>
</ul>
</div>
</div>
</nav>

<!-- Main container for views -->
<main class="routekit-main">
<div class="container">

<% Flash().ShowErrorsIfPresent : Flash().ShowSuccessIfPresent %>

+ 1030
- 0
applicationhost.config
File diff suppressed because it is too large
Näytä tiedosto


+ 23
- 0
core/autoload_core.asp Näytä tiedosto

@@ -0,0 +1,23 @@
<!--#include file="../Core/helpers.asp"-->
<!--#include file="../Core/lib.ErrorHandler.asp"-->
<!--#include file="../Core/lib.ControllerRegistry.asp"-->
<!--#include file="../Core/mvc.asp"-->
<!--#include file="../Core/lib.DAL.asp"-->
<!--#include file="../Core/lib.Data.asp"-->
<!--#include file="../Core/lib.Migrations.asp"-->
<% Dim router : Set router = GetObject("script:"& Server.MapPath("../Core/router.wsc") & "") %>
<!--#include file="../Core/lib.collections.asp"-->
<!--#include file="../Core/lib.HTML.asp"-->
<!--#include file="../Core/lib.Routes.asp"-->
<!--#include file="../Core/lib.Flash.asp"-->
<!--#include file="../Core/lib.FormCache.asp"-->
<!--#include file="../Core/lib.HTML.Security.asp"-->
<!--#include file="../Core/lib.AutoMapper.asp"-->
<!--#include file="../Core/lib.CDOEmail.asp"-->
<!--#include file="../Core/lib.Upload.asp"-->
<!--#include file="../Core/lib.json.asp"-->
<!--#include file="../Core/lib.helpers.asp"-->
<!--#include file="../Core/lib.crypto.helper.asp"-->
<!--#include file="../Core/lib.Enumerable.asp"-->
<!--#include file="../Core/lib.ad.auth.asp"-->
<!--#include file="../Core/databaseConnection.asp"-->

+ 127
- 0
core/databaseConnection.asp Näytä tiedosto

@@ -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
%>

+ 536
- 0
core/helpers.asp Näytä tiedosto

@@ -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 = "<table border='1' cellspacing='0' cellpadding='5'>"
htmlTable = htmlTable & "<thead><tr><th>Variable Name</th><th>Value</th></tr></thead><tbody>"

' Loop through all server variables
For Each varName In Request.ServerVariables
htmlTable = htmlTable & "<tr>"
htmlTable = htmlTable & "<td>" & Server.HTMLEncode(varName) & "</td>"
htmlTable = htmlTable & "<td>" & Server.HTMLEncode(Request.ServerVariables(varName)) & "</td>"
htmlTable = htmlTable & "</tr>"
Next

htmlTable = htmlTable & "</tbody></table>"

' 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 = "<div style='padding:10px; border:2px solid red; background:#fdd; font-family:Verdana; font-size:12px;'>"
errHtml = errHtml & "<strong>Error occurred" & IIf(Not IsEmpty(context) And context <> "", ": " & context, "") & "</strong><br />"
errHtml = errHtml & "<em>Time:</em> " & Now() & "<br />"
errHtml = errHtml & "<em>Number:</em> " & Err.Number & "<br />"
errHtml = errHtml & "<em>Description:</em> " & Server.HTMLEncode(Err.Description) & "<br />"
If Len(Err.Source) > 0 Then
errHtml = errHtml & "<em>Source:</em> " & Server.HTMLEncode(Err.Source) & "<br />"
End If
errHtml = errHtml & "</div>"
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 "<br>"
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 = "<!-- no data -->"
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 = "<!-- missing properties or primary key -->"
Exit Function
End If

html = "<div class='table-wrapper'>" & vbCrLf
html = html & "<table class='pobo-table' id='pobo-table'>" & vbCrLf
html = html & " <thead><tr>" & vbCrLf
For i = 0 To UBound(propNames)
html = html & " <th>" & Server.HTMLEncode(propNames(i)) & "</th>" & vbCrLf
Next
html = html & " </tr></thead>" & vbCrLf
html = html & " <tbody>" & vbCrLf

For j = 0 To UBound(arr)
Set obj = arr(j)
html = html & " <tr>" & 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 = "&nbsp;"
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 = "<a href=""" & obj.Tablename & "/edit/" & GetDynamicProperty(obj, pkName) & """ class=""table-link"">" & val & "</a>"
End If

html = html & " <td>" & val & "</td>" & vbCrLf
Next
html = html & " </tr>" & vbCrLf
Next

html = html & " </tbody>" & vbCrLf & "</table>" & vbCrLf & "</div>"
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 = "<!-- Invalid object -->"
Exit Function
End If

html = "<form method='post' action='/" & tableName & "/save' class='article-content'>" & 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 & " <input type='hidden' name='" & name & "' value='" & Server.HTMLEncode(val) & "' />" & vbCrLf
'Continue For
End If

html = html & " <div class='form-group'>" & vbCrLf
html = html & " <label for='" & name & "'>" & name & "</label>" & vbCrLf

Select Case True
Case VarType(val) = vbBoolean
checkedAttr = ""
If val = True Then checkedAttr = " checked"
html = html & " <input type='checkbox' class='form-check-input' name='" & name & "' id='" & name & "' value='true'" & checkedAttr & " />" & vbCrLf

Case IsDate(val)
html = html & " <input type='date' class='form-control' name='" & name & "' id='" & name & "' value='" & FormatDateForInput(val) & "' />" & vbCrLf

Case IsNumeric(val)
html = html & " <input type='number' class='form-control' name='" & name & "' id='" & name & "' value='" & val & "' />" & vbCrLf

Case Len(val) > CInt(GetAppSetting("FormTextareaThreshold"))
html = html & " <textarea class='form-control' name='" & name & "' id='" & name & "' rows='6'>" & Server.HTMLEncode(val) & "</textarea>" & vbCrLf

Case Else
html = html & " <input type='text' class='form-control' name='" & name & "' id='" & name & "' value='" & Server.HTMLEncode(val) & "' />" & vbCrLf
End Select

html = html & " </div>" & vbCrLf
Next

html = html & " <button type='submit' class='btn btn-primary btn-lg'>Save</button>" & vbCrLf
html = html & "</form>" & 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.<propName> 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

%>

+ 159
- 0
core/lib.Automapper.asp Näytä tiedosto

@@ -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
%>

+ 155
- 0
core/lib.CDOEmail.asp Näytä tiedosto

@@ -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 & "<br/>"
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

%>

+ 914
- 0
core/lib.Collections.asp Näytä tiedosto

@@ -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 & "<br>"
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



%>


+ 116
- 0
core/lib.ControllerRegistry.asp Näytä tiedosto

@@ -0,0 +1,116 @@
<%
'=======================================================================================================================
' 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 valid controllers here
' Format: m_controllers.Add "controllername", True
RegisterController "homecontroller"
RegisterController "errorcontroller"
RegisterController "importcontroller"
RegisterController "businessescontroller"
RegisterController "todaycontroller"
RegisterController "industriescontroller"
RegisterController "exportcontroller"
RegisterController "dashboardcontroller"
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

%>

+ 29
- 0
core/lib.DAL.asp Näytä tiedosto

@@ -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
%>

+ 113
- 0
core/lib.Data.asp Näytä tiedosto

@@ -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
%>

+ 202
- 0
core/lib.Enumerable.asp Näytä tiedosto

@@ -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
%>

+ 178
- 0
core/lib.ErrorHandler.asp Näytä tiedosto

@@ -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 = "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; font-family:Verdana,sans-serif; font-size:14px; border-radius:4px;'>"
errHtml = errHtml & "<strong>Error Occurred</strong><br>"

If Not IsEmpty(context) And Len(context) > 0 Then
errHtml = errHtml & "<strong>Context:</strong> " & Server.HTMLEncode(context) & "<br>"
End If

errHtml = errHtml & "<strong>Time:</strong> " & Now() & "<br>"
errHtml = errHtml & "<strong>Number:</strong> " & errObj.Number & "<br>"
errHtml = errHtml & "<strong>Description:</strong> " & Server.HTMLEncode(errObj.Description) & "<br>"

If Len(errObj.Source) > 0 Then
errHtml = errHtml & "<strong>Source:</strong> " & Server.HTMLEncode(errObj.Source) & "<br>"
End If

errHtml = errHtml & "</div>"
Response.Write errHtml
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Display generic error message (Production mode)
'---------------------------------------------------------------------------------------------------------------------
Private Sub ShowGenericError()
Dim errHtml
errHtml = "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; font-family:Verdana,sans-serif; font-size:14px; border-radius:4px;'>"
errHtml = errHtml & "<strong>An error occurred</strong><br>"
errHtml = errHtml & "We apologize for the inconvenience. The error has been logged and will be investigated.<br>"
errHtml = errHtml & "Please try again later or contact support if the problem persists."
errHtml = errHtml & "</div>"
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

%>

+ 151
- 0
core/lib.Flash.asp Näytä tiedosto

@@ -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
%>
<div id="flashErrorBox" class="alert alert-danger alert-dismissible fade show" role="alert">
<strong>Error!</strong>
<ul class="mb-0 mt-2">
<%
dim ary, i
ary = Errors
for i = 0 to ubound(ary)
put "<li>"
put H(ary(i))
put "</li>"
next
%>
</ul>
<button type="button" class="btn-close" data-bs-dismiss="alert" aria-label="Close"></button>
</div>
<script>
(function() {
var timeout = <%= GetAppSetting("FlashMessageTimeout") %>;
if (isNaN(timeout) || timeout <= 0) timeout = 3000;

setTimeout(function() {
var alertEl = document.getElementById("flashErrorBox");
if (alertEl && typeof bootstrap !== 'undefined') {
var bsAlert = bootstrap.Alert.getOrCreateInstance(alertEl);
bsAlert.close();
} else if (alertEl) {
alertEl.style.display = "none";
}
}, timeout);
})();
</script>
<%
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
%>
<div id="flashSuccessBox" class="alert alert-success alert-dismissible fade show" role="alert">
<%= H(Success) %>
<button type="button" class="btn-close" data-bs-dismiss="alert" aria-label="Close"></button>
</div>
<script>
(function() {
var timeout = <%= GetAppSetting("FlashMessageTimeout") %>;
if (isNaN(timeout) || timeout <= 0) timeout = 3000;

setTimeout(function() {
var alertEl = document.getElementById("flashSuccessBox");
if (alertEl && typeof bootstrap !== 'undefined') {
var bsAlert = bootstrap.Alert.getOrCreateInstance(alertEl);
bsAlert.close();
} else if (alertEl) {
alertEl.style.display = "none";
}
}, timeout);
})();
</script>
<%
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
%>

+ 79
- 0
core/lib.FormCache.asp Näytä tiedosto

@@ -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<br>"
'put "--form_key := " & form_key & "<br>"
'put "--form_val := " & form_val & "<br>"
'put "--serialized_key := " & serialized_key & "<br>"
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 & "<br>"
If InStr(serialized_key, "mvc.form." & form_name) > 0 then
'put "--match" & "<br>"
If dict Is Nothing then
set dict = Server.CreateObject("Scripting.Dictionary")
'put "dict created<br>"
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 & "<br>"
'put "--form_val: " & form_val & "<br>"
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
%>

+ 78
- 0
core/lib.HTML.Security.asp Näytä tiedosto

@@ -0,0 +1,78 @@
<%
'=======================================================================================================================
' 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
token = Session(name & ".anti_csrf_token") ' re-read: the first call used to return the stale empty value
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
%>

+ 282
- 0
core/lib.HTML.asp Näytä tiedosto

@@ -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 = "<a href='" & Encode(Routes.UrlTo(controller_name, action_name, params_array)) & "'" &_
HtmlAttribs(attribs_array) & ">" & link_text & "</a>" & 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 = "<form id='" & id & "' action='" & Routes.UrlTo(controller_name, action_name, empty) & "' method='POST'>"
' dim i, key, val
' for i = 0 to ubound(params) step 2
' KeyVal params, i, key, val
' s = s & "<input type='hidden' name='" & key & "' value='" & val & "'>"
' next
' s = s & "<input type='submit' value='&gt;&gt;'>"
' s = s & "</form>"
' 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 = "<form action='" & Routes.UrlTo(controller_name, action_name, url_params) & "' method='POST' style='margin: 0;'>"
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 & "</form>" & 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 = "<link rel='stylesheet' href='" & Encode(url) & "?" & Year(now) & Month(now) & Day(now) & Hour(now) & Minute(now) & Second(now) & "'>" & vbCR
End Function
Public Function JSTag(url)
JSTag = "<script type='text/javascript' src='" & Encode(url) & "'></script>" & vbCR
End Function
'---------------------------------------------------------------------------------------------------------------------
' Form Helpers
'---------------------------------------------------------------------------------------------------------------------
Public Function FormTag(controller_name, action_name, route_attribs, form_attribs)
FormTag = "<form action='" & Routes.UrlTo(controller_name, action_name, route_attribs) & "' method='POST' " & HtmlAttribs(form_attribs) & ">" & 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 = "<label for='" & Encode(for_name) & "' " & HtmlAttribs(attribs) & ">" & Encode(name) & "</label>" & vbCR
End Function
Public Function Hidden(id, value)
Hidden = HiddenExt(id, value, empty)
End Function
Public Function HiddenExt(id, value, attribs)
HiddenExt = "<input type='hidden' id='" & Encode(id) & "' name='" & Encode(id) & "' value='" & Encode(value) & "' " & HtmlAttribs(attribs) & " >" & vbCR
End Function
Public Function TextBox(id, value)
TextBox = TextBoxExt(id, value, empty)
End Function
Public Function TextBoxExt(id, value, attribs)
TextBoxExt = "<input type='text' id='" & Encode(id) & "' name='" & Encode(id) & "' value='" & Encode(value) & "' " & HtmlAttribs(attribs) & " >" & 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 = "<textarea id='" & Encode(id) & "' name='" & Encode(id) & "' cols='" & Encode(cols) & "' rows='" & Encode(rows) & "' " & HtmlAttribs(attribs) & " >" &_
Encode(value) & "</textarea>" & 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 = "<option value=''>" ' first value is "non-selected" blank state
select case typename(list)
case "Recordset"
do until list.EOF
If IsNull(list(option_value_field)) then
opt_val = ""
Else
opt_val = CStr(list(option_value_field))
End If
opt_txt = list(option_text_field)
If Not IsNull(opt_val) And Not IsEmpty(opt_val) then
options = options & "<option value='" & Encode(opt_val) & "' " & Choice((CStr(opt_val) = CStr(selected_value)), "selected='selected'", "") & ">" & Encode(opt_txt) & "</option>" & 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 & "<option value='" & Encode(opt_val) & "' " & Choice((CStr(opt_val) = CStr(selected_value)), "selected='selected'", "") & ">" & Encode(opt_txt) & "</option>" & vbCR
next
end select
DropDownListExt = "<select id='" & Encode(id) & "' name='" & Encode(id) & "' " & HtmlAttribs(attribs) & " >" & vbCR & options & "</select>" & vbCR
End Function
Public Function Checkbox(id, value)
Checkbox = CheckboxExt(id, value, empty)
End Function
Public Function CheckboxExt(id, value, attribs)
CheckBoxExt = "<input type='checkbox' id='" & Encode(id) & "' name='" & Encode(id) & "' " & Choice( (value = 1) or (value = true) or (LCase(value) = "true") or (LCase(value) = "on"), "checked='checked'", "") & " " & HtmlAttribs(attribs) & ">" & 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 = "<button type='submit' class='btn'>" & text & "</button>" & vbCR
End Function
Public Function Button(button_type, text, class_name)
Button = "<button type='" & Encode(button_type) & "' class='btn " & Encode(class_name) & "'>" & text & "</button>" & vbCR
End Function
Public Function ButtonExt(button_type, text, attribs_array)
ButtonExt = "<button type='" & Encode(button_type) & "' " & HtmlAttribs(attribs_array) & ">" & text & "</button>" & 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_ = "</" & Encode(tag_name) & ">"
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 = "<div class='form-check form-switch'>" & vbCrLf
html = html & " <input class='form-check-input form-control' type='checkbox' id='" & checkboxId & "' name='" & fieldName & "'"
If isChecked Then html = html & " checked"
html = html & ">" & vbCrLf
html = html & " <label class='form-check-label' for='" & checkboxId & "'>" & fieldName & "</label>" & vbCrLf
html = html & "</div>"

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


%>

+ 439
- 0
core/lib.Migrations.asp Näytä tiedosto

@@ -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
%>

+ 262
- 0
core/lib.Routes.asp Näytä tiedosto

@@ -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

%>

+ 73
- 0
core/lib.Strings.asp Näytä tiedosto

@@ -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

%>

+ 405
- 0
core/lib.Upload.asp Näytä tiedosto

@@ -0,0 +1,405 @@
<!--METADATA
TYPE="TypeLib"
NAME="Microsoft ActiveX Data Objects 2.5 Library"
UUID="{00000205-0000-0010-8000-00AA006D2EA4}"
VERSION="2.5"
-->


<%
' 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:<br>"
aKeys = FormElements.Keys
For i = 0 To FormElements.Count -1 ' Iterate the array
response.write aKeys(i) & " = " & FormElements.Item(aKeys(i)) & "<BR>"
Next
response.write "Uploaded Files:<br>"
For Each f In UploadedFiles.Items
response.write "Name: " & f.FileName & "<br>"
response.write "Type: " & f.ContentType & "<br>"
response.write "Start: " & f.Start & "<br>"
response.write "Size: " & f.Length & "<br>"
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 "<br><br><B>System reported this error:</B><p>"
response.write Err.Description & "<p>"
response.write "The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the <A HREF='http://www.freeaspupload.net/freeaspupload/requirements.asp'>requirements page of freeaspupload.net</A>.<p>"
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 <A HREF='http://www.freeaspupload.net/freeaspupload/requirements.asp'>requirements page of freeaspupload.net</A>.<p>"
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
%>

+ 250
- 0
core/lib.Validations.asp Näytä tiedosto

@@ -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
%>

+ 52
- 0
core/lib.ad.auth.asp Näytä tiedosto

@@ -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
%>

+ 45
- 0
core/lib.crypto.helper.asp Näytä tiedosto

@@ -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
%>

+ 115
- 0
core/lib.helpers.asp Näytä tiedosto

@@ -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
%>

+ 284
- 0
core/lib.json.asp Näytä tiedosto

@@ -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



%>

+ 178
- 0
core/mvc.asp Näytä tiedosto

@@ -0,0 +1,178 @@
<!--#include file="../app/Controllers/autoload_controllers.asp" -->
<%
' 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"
' Route parameters for the action being dispatched (referenced by the executed call string, never embedded in it)
Dim MVC_RouteParams

'=======================================================================================================================
' 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)

' Security: Validate controller and action names
If Not ControllerRegistry.IsValidControllerFormat(controllerName) Then
Response.Write "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; border-radius:4px;'>"
Response.Write "<strong>Security Error:</strong> Invalid controller name format."
Response.Write "</div>"
Exit Sub
End If

If Not ControllerRegistry.IsValidActionFormat(actionName) Then
Response.Write "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; border-radius:4px;'>"
Response.Write "<strong>Security Error:</strong> Invalid action name format."
Response.Write "</div>"
Exit Sub
End If

' Security: Check controller whitelist
If Not ControllerRegistry.IsValidController(controllerName) Then
Response.Write "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; border-radius:4px;'>"
Response.Write "<strong>Security Error:</strong> Controller '" & Server.HTMLEncode(controllerName) & "' is not registered."
Response.Write "</div>"
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
%> <!-- #include file="../app/views/Shared/Header.asp" --> <%
End If

' Prepare parameters. They are passed to the action by reference to MVC_RouteParams (see
' ExecuteControllerAction) and are never concatenated into code, so a URL segment cannot inject script.
If hasParams Then
paramsArray = 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
%> <!-- #include file="../app/views/Shared/Footer.asp" --> <%
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, argList, i

' Build the call string based on whether we have parameters. The string only ever contains the validated
' controller/action names and fixed MVC_RouteParams(n) references; the parameter values themselves are
' never part of the executed text.
If Not IsEmpty(paramsArray) And IsArray(paramsArray) And UBound(paramsArray) >= 0 Then
MVC_RouteParams = paramsArray
argList = ""
For i = 0 To UBound(paramsArray)
If i > 0 Then argList = argList & ","
argList = argList & "MVC_RouteParams(" & i & ")"
Next
callString = "Call " & controllerName & "." & actionName & "(" & argList & ")"
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 "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; border-radius:4px;'>"
Response.Write "<strong>Controller Action Error</strong><br>"
Response.Write "Action: <code>" & Server.HTMLEncode(actionName) & "</code><br>"
Response.Write "Error: " & Server.HTMLEncode(errorDesc) & "<br>"
Response.Write "Error Number: " & errorNum
Response.Write "</div>"
Else
Response.Write "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; border-radius:4px;'>"
Response.Write "<strong>An error occurred</strong><br>"
Response.Write "Please contact the system administrator if the problem persists."
Response.Write "</div>"
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
%>

+ 147
- 0
core/router.wsc Näytä tiedosto

@@ -0,0 +1,147 @@
<?xml version="1.0"?>
<!-- RouterComponent.wsc -->
<component>

<!-- COM registration -->
<registration
description = "Classic ASP Router Component"
progid = "App.Router"
version = "1.0"
classid = "{A1FC6EA8-519E-4E34-AC08-77788E3E5E44}" />

<!-- Public interface -->
<public>
<method name="AddRoute"/>
<method name="Resolve"/>
</public>
<!-- Give the component ASP intrinsic objects (Request, Response, Server …) -->
<implements type="ASP"/>
<!-- Implementation -->
<script language="VBScript">
<![CDATA[
Option Explicit

'------------------------------------------------------------
' Private state
'------------------------------------------------------------
Dim routes : Set routes = CreateObject("Scripting.Dictionary")

'------------------------------------------------------------
' METHOD AddRoute(method, path, controller, action)
'------------------------------------------------------------
Public Sub AddRoute(method, path, controller, action)
' Input validation
If IsEmpty(method) Or Len(Trim(method)) = 0 Then
Err.Raise 5, "Router.AddRoute", "HTTP method parameter is required and cannot be empty"
End If

If IsEmpty(path) Then
Err.Raise 5, "Router.AddRoute", "Path parameter is required"
End If

If IsEmpty(controller) Or Len(Trim(controller)) = 0 Then
Err.Raise 5, "Router.AddRoute", "Controller parameter is required and cannot be empty"
End If

If IsEmpty(action) Or Len(Trim(action)) = 0 Then
Err.Raise 5, "Router.AddRoute", "Action parameter is required and cannot be empty"
End If

' Validate HTTP method (allow common methods)
Dim validMethods, methodUpper, i, isValidMethod
validMethods = Array("GET", "POST", "PUT", "DELETE", "PATCH", "HEAD", "OPTIONS")
methodUpper = UCase(Trim(method))
isValidMethod = False

For i = 0 To UBound(validMethods)
If validMethods(i) = methodUpper Then
isValidMethod = True
Exit For
End If
Next

If Not isValidMethod Then
Err.Raise 5, "Router.AddRoute", "Invalid HTTP method: " & method & ". Allowed: GET, POST, PUT, DELETE, PATCH, HEAD, OPTIONS"
End If

Dim routeKey
routeKey = methodUpper & ":" & LCase(Trim(path))

If Not routes.Exists(routeKey) Then
routes.Add routeKey, Array(Trim(controller), Trim(action))
End If
End Sub

'------------------------------------------------------------
' METHOD Resolve(method, path) -> Array(controller, action, params())
'------------------------------------------------------------
Public Function Resolve(method, path)
Dim routeKey, routeValue, values
routeKey = UCase(method) & ":" & LCase(path)

' Always return a params array (empty by default)
Dim emptyParams() : ReDim emptyParams(-1)

' Exact match first
If routes.Exists(routeKey) Then
routeValue = routes(routeKey)
Resolve = Array(routeValue(0), routeValue(1), emptyParams)
Exit Function
End If

' Dynamic routes (e.g. /users/:id)
Dim r, routeMethod, routePattern
For Each r In routes.Keys
routeMethod = Split(r, ":")(0)
routePattern = Mid(r, Len(routeMethod) + 2) ' strip "METHOD:"
If UCase(routeMethod) = UCase(method) Then
If IsMatch(path, routePattern, values) Then
routeValue = routes(r)
Resolve = Array(routeValue(0), routeValue(1), values)
Exit Function
End If
End If
Next

' 404 fallback
Resolve = Array("ErrorController", "NotFound", emptyParams)
End Function

'------------------------------------------------------------
' INTERNAL IsMatch(requestPath, routePattern, values())
' Returns True/False and fills values() with parameters
'------------------------------------------------------------
Private Function IsMatch(requestPath, routePattern, values)
Dim reqParts, routeParts, i, paramCount
reqParts = Split(requestPath, "/")
routeParts = Split(routePattern, "/")

If UBound(reqParts) <> UBound(routeParts) Then
IsMatch = False : Exit Function
End If

paramCount = 0 : ReDim values(-1)

For i = 0 To UBound(reqParts)
If Left(routeParts(i), 1) = ":" Then
ReDim Preserve values(paramCount)
values(paramCount) = reqParts(i)
paramCount = paramCount + 1
ElseIf LCase(routeParts(i)) <> LCase(reqParts(i)) Then
IsMatch = False : Exit Function
End If
Next

If paramCount = 0 Then ReDim values(-1)
IsMatch = True
End Function

'------------------------------------------------------------
' Optional lifecycle hooks
'------------------------------------------------------------
Private Sub Class_Terminate()
Set routes = Nothing
End Sub
]]>
</script>
</component>

+ 14
- 0
db/migrations/20261023160001_create_industries_table.asp Näytä tiedosto

@@ -0,0 +1,14 @@
<%
'=======================================================================================================================
' MIGRATION: create_industries_table
'=======================================================================================================================

Sub Migration_Up(migration)
migration.CreateTable "industries", "id AUTOINCREMENT PRIMARY KEY, name VARCHAR(100) NOT NULL"
migration.ExecuteSQL "CREATE UNIQUE INDEX uq_industries_name ON industries (name)"
End Sub

Sub Migration_Down(migration)
migration.DropTable "industries"
End Sub
%>

+ 13
- 0
db/migrations/20261023160002_create_import_batches_table.asp Näytä tiedosto

@@ -0,0 +1,13 @@
<%
'=======================================================================================================================
' MIGRATION: create_import_batches_table
'=======================================================================================================================

Sub Migration_Up(migration)
migration.CreateTable "import_batches", "id AUTOINCREMENT PRIMARY KEY, file_name VARCHAR(255), imported_at DATETIME, rows_read LONG, rows_added LONG, rows_skipped LONG"
End Sub

Sub Migration_Down(migration)
migration.DropTable "import_batches"
End Sub
%>

+ 26
- 0
db/migrations/20261023160003_create_businesses_table.asp Näytä tiedosto

@@ -0,0 +1,26 @@
<%
'=======================================================================================================================
' MIGRATION: create_businesses_table
'=======================================================================================================================

Sub Migration_Up(migration)
migration.CreateTable "businesses", "id AUTOINCREMENT PRIMARY KEY, " & _
"name VARCHAR(255) NOT NULL, contact_name VARCHAR(150), industry_id LONG, " & _
"phone VARCHAR(40), phone_digits VARCHAR(20), email VARCHAR(255), website VARCHAR(255), " & _
"address1 VARCHAR(255), city VARCHAR(100), state VARCHAR(50), zip VARCHAR(20), source VARCHAR(255), " & _
"status VARCHAR(20) NOT NULL, is_customer SMALLINT, first_order_date DATETIME, notes LONGTEXT, " & _
"next_action_date DATETIME, last_contacted_at DATETIME, removed_reason VARCHAR(255), removed_at DATETIME, " & _
"import_batch_id LONG, created_at DATETIME"
migration.CreateIndex "ix_businesses_phone_digits", "businesses", "phone_digits"
migration.CreateIndex "ix_businesses_email", "businesses", "email"
migration.CreateIndex "ix_businesses_status", "businesses", "status"
migration.CreateIndex "ix_businesses_is_customer", "businesses", "is_customer"
migration.CreateIndex "ix_businesses_industry_id", "businesses", "industry_id"
migration.CreateIndex "ix_businesses_next_action", "businesses", "next_action_date"
migration.CreateIndex "ix_businesses_import_batch", "businesses", "import_batch_id"
End Sub

Sub Migration_Down(migration)
migration.DropTable "businesses"
End Sub
%>

+ 17
- 0
db/migrations/20261023160004_create_interactions_table.asp Näytä tiedosto

@@ -0,0 +1,17 @@
<%
'=======================================================================================================================
' MIGRATION: create_interactions_table
'=======================================================================================================================

Sub Migration_Up(migration)
migration.CreateTable "interactions", "id AUTOINCREMENT PRIMARY KEY, business_id LONG NOT NULL, " & _
"method VARCHAR(10) NOT NULL, outcome VARCHAR(30), notes LONGTEXT, " & _
"contacted_at DATETIME, follow_up_date DATETIME, created_at DATETIME"
migration.CreateIndex "ix_interactions_business_id", "interactions", "business_id"
migration.CreateIndex "ix_interactions_contacted_at", "interactions", "contacted_at"
End Sub

Sub Migration_Down(migration)
migration.DropTable "interactions"
End Sub
%>

+ 1543
- 0
docs/AGENTS.md
File diff suppressed because it is too large
Näytä tiedosto


+ 994
- 0
docs/CLAUDE.md Näytä tiedosto

@@ -0,0 +1,994 @@
# CLAUDE.md

## Purpose

This file defines how Claude and Claude-compatible coding agents should operate in this repository.

Read `AGENTS.md` first.

`AGENTS.md` is the primary development policy.

This file defines agent workflow, reasoning discipline, project learning, and self-improvement behavior.

---

# 1. Startup Procedure

At the beginning of a development task:

1. Read `AGENTS.md`.
2. Read this `CLAUDE.md`.
3. Inspect relevant files before editing.
4. Search the repository for similar implementations.
5. Identify existing helpers and abstractions.
6. Determine the affected architectural layers.
7. Identify security-sensitive boundaries.
8. Identify tests relevant to the change.

Do not immediately generate a new abstraction before understanding the existing project.

---

# 2. Treat VBScript as a Language Requiring Agent-Level Static Analysis

VBScript lacks many safeguards found in modern compiled languages.

Therefore, while working, actively inspect for:

```text
undeclared variables
misspelled identifiers
missing Set
wrong argument counts
implicit Variant conversions
Null propagation
Empty values
Nothing references
unexpected ByRef mutation
invalid function return paths
unsafe SQL
unsafe HTML output
broad error suppression
resource leaks
global-state coupling
```

Act as a compiler substitute.

---

# 3. Think in Boundaries

Before changing code, determine which layer owns the behavior.

Preferred direction:

```text
Request
↓
Controller
↓
Service
↓
Repository
↓
Database
```

Views should receive prepared data.

Do not bypass layers for convenience.

---

# 4. Avoid Architectural Drift

When adding functionality, prefer the project's existing good pattern.

Do not create:

```text
CustomerManager
CustomerHandler
CustomerEngine
CustomerProcessor
CustomerHelper
```

if `CustomerService` already represents the business layer.

Reuse terminology consistently.

---

# 5. Search Before Creating

Before creating:

- a helper
- service
- repository
- validator
- utility
- model
- WSC component
- framework function

search for an existing implementation.

Prefer extending an existing appropriate abstraction over creating duplicates.

---

# 6. Make Small Changes

Prefer the smallest coherent change that solves the problem.

Avoid unrelated cleanup unless necessary.

If a task exposes a larger architectural problem:

1. solve the requested problem safely
2. document the larger concern
3. improve the architecture when justified

Do not turn every bug fix into a rewrite.

---

# 7. Never Hide Errors to Make Code Appear Functional

Do not use broad:

```vbscript
On Error Resume Next
```

to make failures disappear.

Errors should be:

```text
prevented
handled
logged
or propagated
```

Never silently swallowed.

---

# 8. Security Review Is Mandatory

For each change involving input, output, authentication, database access, file handling, or state changes, inspect for:

```text
SQL injection
XSS
CSRF
authorization bypass
open redirects
path traversal
unsafe file upload
sensitive logging
session misuse
```

Security checks are not optional even if the user did not explicitly request them.

---

# 9. SQL Generation

Always prefer parameterized ADODB commands.

If existing code concatenates SQL, do not copy the unsafe pattern into new code.

When touching the unsafe section directly, improve it if doing so is reasonably scoped and compatibility can be preserved.

---

# 10. HTML Generation

Dynamic text should be HTML encoded by default.

Do not output raw Request or database values into HTML.

When raw HTML is intentionally supported, make that trust boundary explicit.

---

# 11. Validate at the Boundary

Convert raw external values into trusted application values early.

Think:

```text
Raw Request value
↓
Trim / normalize
↓
Required check
↓
Format validation
↓
Type conversion
↓
Business validation
↓
Use
```

Do not allow raw Request values to flow deeply through the system.

---

# 12. Prefer Explicit Code

In VBScript, explicit code is usually safer than clever code.

Prefer:

```vbscript
Dim customerId
customerId = CLng(value)
```

over relying on automatic coercion.

Prefer clear control flow over compressed expressions.

---

# 13. Functions and Procedures

Keep procedures focused.

If a function performs several unrelated operations, extract meaningful collaborators.

Prefer names that describe intent.

Bad:

```text
ProcessData
HandleStuff
DoWork
RunThing
```

Better:

```text
ValidateCustomer
CalculateOrderTotal
LoadCustomerById
SaveAppointment
```

---

# 14. ByVal and ByRef

Remember:

VBScript defaults parameters to `ByRef`.

When mutation is not intended, prefer:

```vbscript
ByVal
```

Use `ByRef` only when caller mutation is intentional.

Review changed method signatures for accidental ByRef behavior.

---

# 15. Object Assignment

Remember that object assignment requires `Set`.

Review every new or modified object assignment.

Example:

```vbscript
Set service = New CustomerService
```

not:

```vbscript
service = New CustomerService
```

---

# 16. Function Return Values

VBScript functions return values by assigning to their own name.

Review all paths.

Example:

```vbscript
Function IsAllowed(ByVal userId)

If userId <= 0 Then
IsAllowed = False
Exit Function
End If

IsAllowed = True

End Function
```

Do not accidentally leave an important return value as Empty.

---

# 17. COM and ADODB Cleanup

When creating:

- ADODB.Connection
- ADODB.Command
- ADODB.Recordset
- filesystem objects
- external COM components

understand ownership and cleanup behavior.

Explicitly close database resources when appropriate.

Set references to `Nothing` when ownership ends.

---

# 18. Avoid Global State

Prefer explicit dependencies.

Do not add Session or Application state merely because it is convenient.

Ask:

```text
Does this value truly need to survive across requests?
```

If not, keep it request-scoped.

---

# 19. Testing Strategy

When possible, isolate business logic from ASP globals.

Favor code that can be invoked with plain VBScript values or mock collaborators.

When fixing a defect, add a regression test where practical.

---

# 20. Comments

Comments should explain:

```text
why
constraints
non-obvious behavior
compatibility requirements
security rationale
```

Do not add comments that merely repeat the code.

Bad:

```vbscript
' Set customer id
customerId = 10
```

Useful:

```vbscript
' Legacy import files use 0 to represent an unknown customer.
If customerId = 0 Then
```

---

# 21. Preserve Valuable Legacy Behavior

ASP Classic projects may contain old but important behavior.

Do not assume unfamiliar code is wrong.

Before removing or replacing something:

1. search references
2. understand callers
3. identify side effects
4. inspect related documentation
5. preserve compatibility where required

---

# 22. Self-Improvement

This repository is designed to allow agents to improve their own operating instructions.

Self-improvement should make future work:

- safer
- more consistent
- easier to verify
- less repetitive
- more maintainable

Do not change instructions merely to suit the current implementation.

Improve the implementation when practical rather than weakening good rules.

---

# 23. Detect Learnable Events

A learnable event occurs when:

- a repeated bug appears
- a review catches the same mistake repeatedly
- a new reusable pattern proves successful
- a project architecture decision becomes permanent
- a new security requirement becomes necessary
- a repeated workflow can be standardized
- a user establishes a lasting convention
- an existing instruction becomes inaccurate

When a learnable event occurs, determine whether project documentation should change.

---

# 24. Where Learning Should Go

Use the smallest appropriate scope.

Update:

```text
AGENTS.md
```

for project-wide durable policies.

Update:

```text
CLAUDE.md
```

for agent workflow and Claude-specific operating behavior.

Update:

```text
/docs/*
```

for architectural or project documentation.

Update:

```text
/skills/*
```

for reusable specialized procedures.

Update source-code comments only for code-local constraints.

Do not place every lesson into AGENTS.md.

---

# 25. Self-Update Decision

Before modifying an instruction file, ask:

```text
Is this lesson likely to matter again?
```

If no, do not persist it.

Then ask:

```text
Is this project-wide?
```

If yes, consider AGENTS.md.

Otherwise use a specialized document.

---

# 26. Never Self-Weaken Core Safety Rules

Claude must not autonomously remove or weaken requirements involving:

```text
Option Explicit
parameterized SQL
server-side authorization
input validation
output encoding
safe error handling
resource cleanup
secret protection
```

If an unusual project requirement appears to conflict with one of these rules, preserve safety and document the conflict.

---

# 27. Avoid Instruction Inflation

Do not add a new rule for every isolated mistake.

Prefer:

```text
general principle
+
reusable example
```

rather than hundreds of hyper-specific rules.

A rule should prevent a category of mistakes.

---

# 28. Improve Through Abstractions Too

Not every lesson belongs in documentation.

If the same safety requirement appears repeatedly, consider encoding it into the framework.

Examples:

```text
Safe HTML helper
Parameterized database wrapper
Request conversion helper
Validation library
Authorization service
Logging wrapper
Repository base conventions
```

The best rule is sometimes one the architecture makes difficult to violate.

---

# 29. Skill Creation

Claude may create a new skill when the task is:

- specialized
- recurring
- procedural
- reusable across multiple features

Possible skills:

```text
/skills/asp-classic-controller.md
/skills/adodb-repository.md
/skills/sql-parameterization.md
/skills/security-review.md
/skills/vbscript-static-review.md
/skills/testing.md
```

Do not create a skill for a one-time task.

---

# 30. Suggested Skill Format

Each skill should contain:

```text
# Skill Name

## Purpose

## Use When

## Inputs

## Procedure

## Required Rules

## Validation Checklist

## Common Mistakes

## Output

## Improvement Notes
```

---

# 31. Agent Review Loop

For meaningful tasks, use this cycle:

```text
Understand
↓
Inspect
↓
Design
↓
Implement
↓
Review
↓
Test
↓
Learn
```

The `Learn` step asks whether the repository's instructions or abstractions should improve.

---

# 32. Design Before Implementation

For significant changes, identify:

```text
affected layers
new components
existing components
data flow
validation boundaries
security boundaries
failure behavior
testing strategy
```

before writing substantial code.

For small tasks, keep this lightweight.

---

# 33. Avoid Premature Framework Expansion

Do not add framework components simply because another language would have them.

ASP Classic should remain simple.

Only introduce an abstraction when it solves a real recurring problem.

---

# 34. Prefer Composition

When extending behavior, first consider:

```text
small object
+
small collaborator
```

instead of large pseudo-inheritance systems.

VBScript is better suited to simple composition.

---

# 35. Stable Public Contracts

Treat established routes, APIs, class methods, and database contracts carefully.

When changing them:

1. search callers
2. assess compatibility
3. update all consumers
4. document breaking changes

Avoid accidental interface changes.

---

# 36. Database Changes

For schema changes, consider:

```text
backward compatibility
migration order
existing data
Null behavior
indexes
constraints
application deployment timing
rollback implications
```

Do not modify schema casually.

---

# 37. Performance Review

When working with database code, look for:

```text
queries inside loops
SELECT *
unnecessary recordset traversal
missing filters
repeated connection creation
large Session values
unbounded result sets
unnecessary COM calls
```

Prefer database-side filtering and set operations.

---

# 38. Request Lifecycle Awareness

Remember that ASP Classic operates per request.

Avoid assumptions that local variables persist between requests.

Use Session or persistent storage only when the application truly requires cross-request state.

---

# 39. Application Lifecycle Awareness

`Application` state is global to the ASP application.

Do not store user-specific data there.

Be mindful of concurrent requests.

---

# 40. Avoid Hidden Dependencies

A component should not unexpectedly require:

```text
Request
Response
Session
Application
global connection object
global logger
global configuration
```

unless that dependency is part of the documented architecture.

Prefer passing dependencies explicitly.

---

# 41. Compatibility First During Refactoring

When modernizing legacy code:

```text
First preserve behavior.
Then improve structure.
```

Avoid combining major behavior changes with major refactors unless necessary.

---

# 42. Repository Review After Significant Changes

After a meaningful feature or refactor, search for:

- outdated documentation
- duplicate helpers
- now-dead code
- inconsistent naming
- old patterns replaced by the new pattern
- opportunities to update an existing skill

Keep the repository internally consistent.

---

# 43. Learn From User Corrections

If the user corrects Claude on a durable project convention, treat that as a possible learnable event.

Examples:

```text
"We always use this router."
"Repositories never return recordsets."
"All AJAX endpoints use this response format."
"Use WSC components for controllers."
```

If the instruction is durable, update the appropriate project guidance.

Do not persist one-time preferences as permanent architecture rules.

---

# 44. Change Documentation Conservatively

When modifying AGENTS.md, CLAUDE.md, or skills:

- preserve useful existing rules
- remove duplicates
- clarify contradictions
- avoid unnecessary rewrites
- add an update-history entry where appropriate

Instruction files should become clearer over time, not merely longer.

---

# 45. Conflict Detection

If project documentation contradicts itself:

1. identify the conflict
2. use higher-priority instructions
3. resolve the contradiction where safe
4. update documentation so future agents do not face the same conflict

Do not silently choose different interpretations from task to task.

---

# 46. Self-Improvement Is Not Autonomous Product Redesign

Claude may improve:

```text
guidelines
skills
documentation
developer workflow
internal abstractions
```

when justified.

Claude must not independently redefine:

```text
business requirements
user-visible behavior
pricing
authorization policy
data retention policy
major architecture goals
```

without task requirements supporting the change.

---

# 47. Final Review Mode

Before completing a task, temporarily switch from implementation thinking to adversarial review.

Ask:

```text
How could this fail?

What would VBScript fail to warn me about?

What input breaks this?

What happens with Null?

What happens with Empty?

What happens with Nothing?

Did I forget Set?

Could ByRef change the caller?

Could SQL injection occur?

Could XSS occur?

Could authorization be bypassed?

Could an error be swallowed?

Could a recordset remain open?

Did I accidentally duplicate existing functionality?
```

Fix issues found before finishing.

---

# 48. Final Summary

When reporting completed coding work, mention material items such as:

```text
what changed
important architecture choices
tests performed
security implications
documentation or rule updates
remaining limitations
```

Do not produce long explanations for trivial changes.

---

# 49. Core Philosophy

Claude should help make ASP Classic behave like a disciplined modern development environment without destroying the language's simplicity.

The goal is not to turn VBScript into C#.

The goal is to provide the safeguards that VBScript lacks.

Think:

```text
VBScript
+
clear architecture
+
strict conventions
+
reusable framework components
+
agent-level static analysis
+
continuous learning
=
reliable ASP Classic development
```

---

# Update History

2026-09-02
- Initial Claude operating instructions created.
- Added VBScript static-review behavior.
- Added controlled self-improvement workflow.
- Added learnable-event detection and skill creation guidance.

BIN
docs/Windows scripting secrets.pdf Näytä tiedosto


+ 63
- 0
docs/api-contracts-mvc-starter.md Näytä tiedosto

@@ -0,0 +1,63 @@
# API Contracts - MVC-Starter

**Date:** 2026-03-11T11:59:39Z

## Overview

This project does not expose a standalone JSON API. Its current externally reachable contracts are server-rendered HTTP routes handled by the Classic ASP MVC dispatcher.

## Route Catalog

### `GET /`

- **Controller:** `homeController`
- **Action:** `Index`
- **Behavior:** Renders the home page using the shared layout and `app/views/Home/index.asp`.
- **Layout:** enabled (`useLayout = True`)
- **Response Type:** HTML
- **Status:** `200 OK`

### `GET /home`

- **Controller:** `homeController`
- **Action:** `Index`
- **Behavior:** Alias route to the home page; renders the same content as `/`.
- **Layout:** enabled
- **Response Type:** HTML
- **Status:** `200 OK`

### `GET ""` (empty path fallback)

- **Controller:** `homeController`
- **Action:** `Index`
- **Behavior:** Additional root-path fallback route declared in `public/Default.asp`.
- **Layout:** enabled
- **Response Type:** HTML
- **Status:** `200 OK`

### `GET /404`

- **Controller:** `ErrorController`
- **Action:** `NotFound`
- **Behavior:** Renders the not-found page and sets the response status to `404 Not Found`.
- **Layout:** enabled
- **Response Type:** HTML
- **Status:** `404 Not Found`

## Dispatch Contract

- All non-static requests are rewritten by IIS to `public/Default.asp`.
- `public/Default.asp` registers routes and calls `MVC.DispatchRequest`.
- `core/mvc.asp` validates controller and action names, checks the controller whitelist, resolves the controller dynamically, and invokes the action.
- If `useLayout` is enabled on the resolved controller, shared header and footer views wrap the response.

## Security and Validation Notes

- Controller names must pass format validation and whitelist checks in `core/lib.ControllerRegistry.asp`.
- Action names must pass identifier validation before dispatch.
- Current route handling is page-oriented; there are no documented JSON payload schemas or standalone API auth flows in the application itself.

## Brownfield Notes

- Future endpoint additions require updates in at least three places: route registration, controller include/implementation, and controller whitelist registration.
- This document reflects route contracts, not REST-style service endpoints.

+ 34
- 0
docs/architecture-patterns.md Näytä tiedosto

@@ -0,0 +1,34 @@
# Architecture Patterns

**Date:** 2026-03-11T11:59:39Z

## Part: MVC-Starter

### Primary Architecture Pattern

Server-rendered MVC monolith with a starter/framework hybrid structure: IIS and `public/` handle request entry, `core/` provides shared runtime and dispatch behavior, and `app/` provides project-specific extensions.

## Pattern Breakdown

- **End-to-end request path:** IIS URL Rewrite sends requests to `public/Default.asp`, routes are registered there, the router resolves controller/action/params, `core/mvc.asp` validates and dispatches, and shared layout files wrap output when `useLayout` is enabled.
- **Routing pattern:** Routes are declared centrally in `public/Default.asp` and resolved through the RouteKit router object.
- **Dispatch pattern:** `core/mvc.asp` uses validation, controller whitelisting, and dynamic execution to resolve the current controller and action.
- **Application layering:** `core/` contains reusable framework/runtime behavior, while `app/` contains project-specific controllers, views, models, and repositories.
- **Rendering pattern:** Controllers orchestrate and include `.asp` view files; shared header/footer layout files provide common page chrome.
- **Data pattern:** Data access is config-driven through `public/web.config`, with DAL libraries and generator-assisted repositories/POBOs supporting database interaction.
- **Operational tooling pattern:** Schema and scaffolding workflows are handled by standalone VBScript tools under `scripts/`.

## Architectural Implications

- This codebase is optimized around a single IIS-hosted deployable unit rather than separable services.
- Framework bootstrapping and request dispatch are centralized, so edits to `public/` entry files or `core/` runtime files have broad impact.
- Dynamic dispatch is part of the framework design, which makes naming, registration, and validation rules part of the architecture contract.
- Feature development typically extends existing seams in `app/`, `db/`, and `scripts/` rather than introducing new application subsystems.
- The architecture assumes server-side HTML rendering and config-driven runtime behavior rather than client-heavy SPA patterns.

## Brownfield Notes

- The most important architectural boundary is between the framework/runtime layer (`core/`) and the app extension layer (`app/`).
- Controller activation is not automatic; routing, include registration, and whitelist registration are all part of the runtime contract.
- Windows/IIS hosting is part of the architecture, not just deployment detail, because request flow and configuration depend on it.
- Generator scripts are part of the implementation model, not just convenience tooling.

+ 81
- 0
docs/architecture.md Näytä tiedosto

@@ -0,0 +1,81 @@
# MVC-Starter - Architecture

**Date:** 2026-03-11T11:59:39Z
**Project Type:** web
**Architecture:** Server-rendered MVC monolith

## Executive Summary

MVC-Starter is a Classic ASP starter application built around a single IIS-hosted deployable unit. Requests enter through `public/Default.asp`, flow through a shared runtime in `core/`, and resolve into application-specific controllers and views under `app/`.

## Technology Stack

- Classic ASP / VBScript
- Windows IIS with URL Rewrite
- RouteKit-style router and MVC dispatcher
- Microsoft Access via ACE OLE DB
- Bootstrap 5.3.3 and Bootstrap Icons 1.11.3 from CDN
- VBScript tooling for scaffolding and migrations

## Architecture Pattern

Starter/framework hybrid MVC monolith:

- `public/` handles web entry and IIS-facing config
- `core/` handles routing, dispatch, validation, helpers, and DAL concerns
- `app/` contains project-specific behavior and server-rendered views
- `db/` and `scripts/` support data and operational workflows

## Request Flow

1. IIS receives the request.
2. `public/web.config` rewrites non-static requests to `public/Default.asp`.
3. `Default.asp` registers routes and calls `MVC.DispatchRequest`.
4. `core/mvc.asp` validates controller/action names, checks whitelist registration, resolves the current controller dynamically, and executes the target action.
5. Shared layout files wrap the response if `useLayout` is enabled.

## Data Architecture

- Database configuration is read from `public/web.config`.
- `db/webdata.accdb` is the included Access database.
- DAL and migration helpers live in `core/`.
- Repositories and POBOs are expected to be generated via `scripts/GenerateRepo.vbs`.

## Component Overview

- Controllers: `app/controllers/`
- Views: `app/views/`
- Shared layout: `app/views/shared/`
- Runtime/framework: `core/`
- Scaffolding/tooling: `scripts/`

## Source Tree

See [source-tree-analysis.md](./source-tree-analysis.md) for the annotated directory breakdown.

## Development Workflow

- Generate migration
- Generate POBO/repository
- Generate controller
- Register controller include, whitelist, and routes
- Add views and validate via IIS-hosted execution

## Deployment Architecture

- Single IIS site
- `public/` as web root
- XML config in `public/web.config`
- No separate service/process topology detected

## Testing Strategy

- No automated test framework detected
- Manual request-flow verification is required
- Script tooling can be validated via `cscript`

## Architectural Constraints

- Dynamic dispatch means naming and registration consistency are part of runtime correctness.
- `core/`, `public/Default.asp`, and `public/web.config` are high-impact files.
- The architecture assumes Windows/IIS hosting rather than cross-platform portability.

+ 63
- 0
docs/component-inventory.md Näytä tiedosto

@@ -0,0 +1,63 @@
# MVC-Starter - Component Inventory

**Date:** 2026-03-11T11:59:39Z

## Runtime and MVC Components

### Front Controller

- `public/Default.asp`
- Registers routes
- Boots runtime
- Dispatches requests

### Dispatcher

- `core/mvc.asp`
- Validates controller/action names
- Enforces controller whitelist
- Wraps responses in shared layout when enabled

### Controller Registry

- `core/lib.ControllerRegistry.asp`
- Tracks valid controllers
- Prevents arbitrary controller execution

### Controllers

- `app/controllers/HomeController.asp`
- Home page controller
- `app/controllers/ErrorController.asp`
- 404/not-found handling

## UI/View Components

### Shared Layout

- `app/views/shared/header.asp`
- `app/views/shared/footer.asp`

### Feature Views

- `app/views/Home/index.asp`
- `app/views/Error/NotFound.asp`

## Data/Operational Components

### Database Assets

- `db/webdata.accdb`

### Script Tooling

- `scripts/generateController.vbs`
- `scripts/GenerateRepo.vbs`
- `scripts/generateMigration.vbs`
- `scripts/runMigrations.vbs`

## Reuse Notes

- The main reusable UI surface is the shared layout.
- The main reusable runtime surface is the `core/` library set.
- The data layer is scaffold-oriented and currently has no committed application-specific model/repository classes.

+ 46
- 0
docs/comprehensive-analysis-mvc-starter.md Näytä tiedosto

@@ -0,0 +1,46 @@
# Comprehensive Analysis - MVC-Starter

**Date:** 2026-03-11T11:59:39Z

## Configuration Management

- Primary runtime configuration lives in `public/web.config`.
- Important settings include database connection, environment mode, flash timing, 404 redirect timing, cache controls, and error logging paths.
- Configuration is read in application code through helper accessors such as `GetAppSetting`.

## Authentication and Security

- No full authentication subsystem is present in the starter.
- The main observable security boundary is controller/action validation and controller whitelisting in `core/lib.ControllerRegistry.asp`.
- Dispatch also HTML-encodes some user-visible error output to reduce injection risk.

## Entry Points and Bootstrap

- IIS web root: `public/`
- Default document: `public/Default.asp`
- Runtime bootstrap include: `core/autoload_core.asp`
- Request dispatcher: `core/mvc.asp`

## Shared Code

- `core/` contains reusable framework/runtime libraries for routing, data access, flash messaging, forms, uploads, HTML helpers, validation, encryption helpers, and JSON support.
- `scripts/` contains operational generators and migration tooling.

## Event/Async Patterns

- No queue, worker, or event-bus architecture was detected.
- UI behavior is mostly server-rendered with small inline browser-side scripts where needed.

## CI/CD and Deployment

- No CI/CD pipeline configuration was detected.
- Deployment is IIS-based and documented in `README.md` and `public/web.config`.

## Localization

- No localization or i18n framework was detected.

## Testing Surface

- No automated test framework or test files were detected in the application code.
- Validation currently depends on manual runtime checks and script execution in a Windows/IIS environment.

+ 11
- 0
docs/critical-folders-summary.md Näytä tiedosto

@@ -0,0 +1,11 @@
# Critical Folders Summary

**Date:** 2026-03-11T11:59:39Z

- `public/`: externally facing web root, rewrite config, and request bootstrap
- `core/`: framework/runtime internals, dispatcher, router, helpers, DAL, and security checks
- `app/controllers/`: project controller implementations and include-based activation surface
- `app/views/`: server-rendered feature views and shared layout
- `db/`: Access database and migration workspace
- `scripts/`: generator and migration tooling used during feature development
- `docs/`: generated brownfield documentation for future planning and AI-assisted work

+ 42
- 0
docs/data-models-mvc-starter.md Näytä tiedosto

@@ -0,0 +1,42 @@
# Data Models - MVC-Starter

**Date:** 2026-03-11T11:59:39Z

## Overview

The repository includes a database file and data-access infrastructure, but it does not yet contain checked-in application model or repository source files under `app/models/` or `app/repositories/`.

## Current Data Assets

### Database File

- **Path:** `db/webdata.accdb`
- **Type:** Microsoft Access database
- **Configured Provider:** `Microsoft.ACE.OLEDB.12.0`
- **Configured From:** `public/web.config`

### Data Access Runtime

- **DAL libraries:** `core/lib.DAL.asp`, `core/lib.Data.asp`
- **Migration support:** `core/lib.Migrations.asp`
- **Repository/model generation:** `scripts/GenerateRepo.vbs`

## Schema and Model Strategy

- The intended model pattern is generator-assisted.
- `GenerateRepo.vbs` inspects a target table and produces:
- `POBO_<Table>.asp`
- `<Table>Repository.asp`
- Generated outputs are expected to be moved into `app/models/` and `app/repositories/`.

## Current Repository State

- `app/models/` is currently empty.
- `app/repositories/` is currently empty.
- `db/migrations/` currently has no checked-in migration files.

## Brownfield Implications

- The project is database-capable, but the sample starter does not include domain entities yet.
- Schema evolution and repository creation are expected to happen through the provided VBScript tooling rather than a separate ORM or package-managed migration framework.
- Future data documentation should be regenerated once concrete tables, migration files, or generated POBO/repository files are added.

+ 82
- 0
docs/deployment-configuration.md Näytä tiedosto

@@ -0,0 +1,82 @@
# Deployment Configuration

## Dedicated defaults

The deployment controller and host installer use the same isolated defaults:

| Parameter | Default |
| --- | --- |
| `SiteName` | `AspClassicUnifiedFramework` |
| `AppPoolName` | `AspClassicUnifiedFramework` |
| `DeployRoot` | `D:\Deployments\AspClassicUnifiedFramework` |
| `BindingIpAddress` | `100.97.39.23` |
| `BindingPort` | `8085` |
| `HostHeader` | empty |
| `ExpectedBranch` | `master` (controller) |

Every value can be explicitly overridden. Site and pool names, deployment root, and host header containing `Schedulicious` are rejected as an additional safety boundary. The scripts do not enumerate another site as a configuration source and provide no adoption switch.

## Configuration ownership

Repository `public\web.config` is the default template for first deployment. After the package is safely extracted and validated, the host installer initializes:

```text
<DeployRoot>\shared\public.web.config
```

from the staged package's `public\web.config`. If `InitialWebConfigPath` is supplied on that first deployment, the validated host-local file at that path is used instead. The parameter does not replace an existing shared configuration. Configuration is never copied from another IIS site.

Every staged release receives the shared file before promotion. Change the shared file only through normal host configuration/change control and validate its XML. Keep secrets and production database paths out of source control.

## IIS state owned by the pipeline

The pipeline owns only the named dedicated site and app pool. It may:

1. create them, only when both are absent and only after a staged release validates;
2. point the dedicated site at `<DeployRoot>\releases\<release-id>\public`;
3. set `system.webServer/asp enableParentPaths=true` at that site's location;
4. start/recycle the dedicated app pool and start a newly created site.

It does not alter unrelated sites, app pools, bindings, authentication, identities, ACLs, Windows features, or IIS modules. It does not add bindings to an existing site.

When the target already exists, the site and pool must both exist and exactly match the requested app pool, sole HTTP binding, and pipeline-owned release-public path. Any mismatch fails closed.

## Controller parameters

`scripts/deploy-iis-git.ps1` supports:

- `SiteName`, `AppPoolName`, `DeployRoot`, `BindingIpAddress`, `BindingPort`, `HostHeader`: dedicated target identity and binding.
- `InitialWebConfigPath`: optional host-local first-deployment seed.
- `RemoteTarget`, `RemotePort`: OpenSSH transport.
- `SourcePath`: standalone checkout to validate/package.
- `ExpectedBranch`: remains `master` by default.
- `ReleaseId`: optional immutable release identifier.
- `BaseUrl`: explicit host-side smoke-test URL.
- `KeepReleases`: reporting threshold only; no deletion.
- `LocalPreflightOnly`: local source/XML/package/safety validation; no network.
- `PreflightOnly` (`HostPreflightOnly` and `RemotePreflightOnly` aliases): run local/package checks, then stream the installer over SSH for host validation without writing remote files or changing IIS/deployment state.
- `DryRun`: local package validation plus remote command preview; no network.
- `AllowAnyBranch`, `AllowDirty`: reviewed provenance exceptions.
- `RunMigrations`: explicit database migration opt-in.
- `SkipSmokeTest`: explicit smoke-test exception.
- `Rollback` and `RollbackTo`: switch the dedicated target to a validated prior release.

## Host installer parameters

`scripts/install-iis-release.ps1` accepts the same target/configuration parameters plus:

- `PackagePath`, `ReleaseId`, `ExpectedSha256`: deployment artifact inputs.
- `PreflightOnly` or `DryRun`: read-only host checks; the target may be absent.
- `RollbackTo`: validated release ID for rollback.

Host preflight requires elevation and verifies WebAdministration, Classic ASP feature and `AspModule`, URL Rewrite, requested binding conflicts (including wildcard overlap), shared-pool conflicts, deployment drive/path accessibility, names, and exact existing-target state. It makes no IIS or deployment-root changes.

## Failure scope

If creation or smoke testing fails, the installer removes only a site or app pool whose creation flags were set by that invocation. For an existing valid target, it restores the captured physical path and parent-path value. Unrelated IIS resources are never cleanup candidates.

Package staging/release files can remain as diagnostic evidence. Database migrations and external writes are outside IIS rollback.

## Secrets, identity, and writable data

Use OpenSSH configuration, an SSH agent, or a CI secret store. Do not commit passwords, private keys, production connection strings, or database files. Put production databases and logs outside release directories. App-pool identity and filesystem ACL provisioning are explicit host-administration tasks, not inferred from another site.

+ 134
- 0
docs/deployment-guide.md Näytä tiedosto

@@ -0,0 +1,134 @@
# IIS Deployment Guide

## Isolation boundary

This pipeline owns one dedicated IIS site and one dedicated application pool. It never discovers, copies configuration from, adopts, or changes another IIS site. In particular, no existing Schedulicious site, app pool, binding, path, or configuration is a deployment source or target.

Defaults (each may be overridden explicitly):

```text
SiteName AspClassicUnifiedFramework
AppPoolName AspClassicUnifiedFramework
DeployRoot D:\Deployments\AspClassicUnifiedFramework
Binding http://100.97.39.23:8085/ (empty host header)
ExpectedBranch master
```

An existing target is accepted only when its name, app pool, sole HTTP binding, and physical path exactly match this pipeline's expected dedicated state. The physical path must be a `public` directory under `<DeployRoot>\releases`. A partial or mismatched target fails closed; there is no adoption mode. Unrelated sites, pools, and bindings are left unchanged.

## Release and web-root model

```text
D:\Deployments\AspClassicUnifiedFramework\
releases\
<release-id>\
app\
core\
db\
public\ <- only this directory is served by IIS
scripts\
tests\
...
shared\
public.web.config
deployment-state.json
```

The complete repository is packaged because `public/Default.asp` uses parent includes from sibling directories. Releases are extracted into `<release-id>.staging`, checked for required files, safe paths/reparse points, and valid `public\web.config` XML, overlaid with shared configuration, and renamed to an immutable release directory. IIS serves only `<release>\public`.

On the first deployment, shared configuration is initialized from the packaged release's `public\web.config`. Supply `-InitialWebConfigPath` only when an explicitly managed host-local configuration file should seed the first deployment. The script validates that file as XML. It never copies configuration from any IIS site. Once created, the shared file is reused and is not automatically refreshed.

Classic ASP parent paths are enabled with a location-scoped `system.webServer/asp` setting for this dedicated site only.

## Scripts

- `scripts/deploy-iis-git.ps1`: controller entry point; validates source, branch, XML, package structure, and safety; hashes and optionally transfers the package.
- `scripts/install-iis-release.ps1`: elevated Windows PowerShell 5.1 host installer; performs read-only host preflight, stages and validates releases, creates/manages only the dedicated target, switches releases, smoke tests, and rolls back target mutations on failure.

Gitea 1.11.4 predates Gitea Actions. Run the controller from a trusted external worker or operator workstation with approved Tailscale/OpenSSH access. No credentials or production configuration belong in this repository.

## Preflight sequence

### 1. Local/controller preflight (no network)

Run from a clean standalone `master` checkout:

```powershell
.\scripts\deploy-iis-git.ps1 -LocalPreflightOnly
```

This validates the dedicated names/binding/root, source provenance, required source files, repository `public\web.config` XML, package creation, extracted package layout, and reparse-point/symlink safety. It does not call SSH/SCP and makes no host change. `-AllowAnyBranch` is still required when the source is not a standalone Git checkout.

`-DryRun` also avoids network access but prints the remote operation that would be performed.

### 2. Full preflight (connects, read-only)

```powershell
.\scripts\deploy-iis-git.ps1 -PreflightOnly -RemoteTarget 'webserver-1'
```

After the local/package checks, the controller streams the installer over SSH and runs it in memory; it does not create a remote transport directory or copy a remote file. The host phase checks elevation, WebAdministration, Classic ASP feature/module, URL Rewrite module, deployment drive/path and resource names, binding conflicts (including wildcard IP overlap), shared-pool conflicts, and existing dedicated target consistency. The dedicated site and pool do not need to exist. No IIS or deployment-root change is made. `-HostPreflightOnly` and `-RemotePreflightOnly` remain aliases.

## First deployment

The installer creates the dedicated app pool and site only after the staged release and selected initial `web.config` validate. Example using all defaults:

```powershell
.\scripts\deploy-iis-git.ps1 -RemoteTarget 'webserver-1'
```

Example with explicit overrides:

```powershell
.\scripts\deploy-iis-git.ps1 `
-SiteName 'AspClassicUnifiedFramework-Test' `
-AppPoolName 'AspClassicUnifiedFramework-Test' `
-DeployRoot 'E:\Deployments\AspClassicUnifiedFramework-Test' `
-BindingIpAddress '100.97.39.23' `
-BindingPort 8185 `
-HostHeader 'framework-test.internal' `
-InitialWebConfigPath 'E:\ManagedConfig\framework-test.web.config' `
-RemoteTarget 'webserver-1' `
-ExpectedBranch 'master'
```

The new app pool uses no managed CLR. Configure any required app-pool identity and ACL policy through separately reviewed host preparation; the deployment does not borrow another pool's identity or permissions.

## Existing target and cutover

For later deployments, the host preflight requires the dedicated site to use:

- exactly `AppPoolName`;
- exactly one HTTP binding matching IP, port, and host header;
- a physical path ending in `\public` under `<DeployRoot>\releases`.

Any mismatch fails without mutation. After the new release validates, the installer changes only the dedicated site's physical path, applies the site-location parent-path setting, recycles/starts the dedicated pool, and smoke tests the configured binding or explicit `-BaseUrl`.

## Failure recovery

The installer records whether this invocation created the target site or pool and snapshots the prior state of an existing valid target.

- If target creation or smoke testing fails, it removes only the site/app pool created by this invocation.
- If an existing target fails during cutover or smoke testing, it restores its previous physical path and previous site-location parent-path value, then restarts/recycles its pool.
- It never removes or edits an unrelated site, pool, or binding.
- Staging/release files may remain for diagnosis; releases are reported as retention candidates and are never deleted automatically.
- Explicit database migrations cannot be undone by IIS rollback.

## Rollback

```powershell
.\scripts\deploy-iis-git.ps1 `
-Rollback `
-RollbackTo '20260914-171500-a1b2c3d4e5f6' `
-RemoteTarget 'webserver-1'
```

Rollback requires an already valid dedicated target and an existing immutable release under the configured `DeployRoot`. It switches only that target's physical path and smoke tests; it does not rewrite the prior release. Failure restores the prior target state.

## Database and writable data

Migrations are disabled by default. `-RunMigrations` is an explicit exception and requires a verified backup; path rollback cannot undo database changes. Keep production databases, logs, and other writable data outside immutable release directories and grant the dedicated app-pool identity only necessary permissions.

## Windows verification gates

Before production use, validate both scripts with the Windows PowerShell 5.1 parser, run host preflight on the intended Windows/IIS host, deploy to an isolated test name/binding, verify HTTP and parent includes, induce a smoke failure to prove invocation-scoped cleanup/restoration, then prove rollback. Linux checks cannot validate WebAdministration behavior, installed IIS features/modules, binding semantics on the live host, elevation, ACLs, app-pool identity, Access/ACE, or an actual HTTP response.

+ 55
- 0
docs/development-guide.md Näytä tiedosto

@@ -0,0 +1,55 @@
# MVC-Starter - Development Guide

**Date:** 2026-03-11T11:59:39Z

## Prerequisites

- Windows environment
- IIS with Classic ASP enabled
- IIS URL Rewrite module
- Microsoft Access Database Engine
- Windows Script Host (`cscript`)

## Local Setup

1. Place the project on a Windows machine with IIS.
2. Point the site root to `public/`.
3. Update `public/web.config` for the correct database and logging paths.
4. Browse to `/` and confirm the starter home page renders.

## Common Workflows

### Add a database-backed feature

1. Generate a migration
2. Generate POBO/repository
3. Move generated files into `app/models/` and `app/repositories/`
4. Generate a controller
5. Include the controller from `app/controllers/autoload_controllers.asp`
6. Register the controller in `core/lib.ControllerRegistry.asp`
7. Add routes in `public/Default.asp`
8. Add corresponding views in `app/views/`

### Useful Commands

```bat
cscript //nologo scripts\generateMigration.vbs create_my_table
cscript //nologo scripts\GenerateRepo.vbs /table:my_table /pk:id
cscript //nologo scripts\generateController.vbs MyController "Index;Show(id)"
cscript //nologo scripts\runMigrations.vbs status
```

## Testing Approach

- Manual runtime validation through IIS
- Manual route/layout verification after controller or view changes
- Script validation through `cscript`
- No built-in automated test suite detected

## High-Risk Change Areas

- `public/Default.asp`
- `public/web.config`
- `core/mvc.asp`
- `core/lib.ControllerRegistry.asp`
- shared layout files under `app/views/shared/`

+ 59
- 0
docs/development-instructions.md Näytä tiedosto

@@ -0,0 +1,59 @@
# Development Instructions

**Date:** 2026-03-11T11:59:39Z

## Prerequisites

- Windows Server or Windows development environment
- IIS with Classic ASP enabled
- IIS URL Rewrite module
- Microsoft Access Database Engine for `.accdb` support
- Windows Script Host / `cscript`

## Setup

1. Copy the project to the target IIS host.
2. Point the IIS site root to `public/`.
3. Update `public/web.config`:
- `ConnectionString`
- `ErrorLogPath` if logging is desired
4. Ensure the Access database file path is valid for the environment.

## Common Development Tasks

### Generate a migration

```bat
cscript //nologo scripts\generateMigration.vbs create_my_table
```

### Generate POBO and repository

```bat
cscript //nologo scripts\GenerateRepo.vbs /table:my_table /pk:id
```

Move generated files into `app/models/` and `app/repositories/`.

### Generate a controller

```bat
cscript //nologo scripts\generateController.vbs MyController "Index;Show(id);Create;Store"
```

Move the generated controller into `app/controllers/`.

### Activate a controller

After generating a controller:

1. Include it from `app/controllers/autoload_controllers.asp`
2. Register it in `core/lib.ControllerRegistry.asp`
3. Add routes in `public/Default.asp`
4. Create corresponding views in `app/views/`

## Validation Approach

- Manual browser validation is required for runtime changes.
- Route/layout changes should be checked through IIS-hosted execution.
- Migration and generator changes should be validated with `cscript`.

+ 46
- 0
docs/existing-documentation-inventory.md Näytä tiedosto

@@ -0,0 +1,46 @@
# Existing Documentation Inventory

**Date:** 2026-03-11T11:59:39Z

## Summary

The project has a small set of directly relevant documentation files plus BMAD framework support files. For brownfield understanding, the highest-priority sources are the project README and a small number of repo-specific instruction files.

## Priority Documentation for Project Understanding

### `README.md`

- **Type:** readme
- **Path:** `/workspace/MVC-Starter/README.md`
- **Scope:** whole project
- **Notes:** Documents IIS setup, project structure, generator workflow, and baseline runtime requirements.

### `.github/copilot-instructions.md`

- **Type:** project instructions
- **Path:** `/workspace/MVC-Starter/.github/copilot-instructions.md`
- **Scope:** whole project
- **Notes:** Documents BMAD runtime conventions, config locations, workflow engine usage, and agent/runtime structure.

### `_bmad-output/project-context.md`

- **Type:** generated ai-project-context
- **Path:** `/workspace/MVC-Starter/_bmad-output/project-context.md`
- **Scope:** whole project
- **Notes:** Derivative documentation generated from workflow analysis. Useful for AI implementation rules, but not an original source of project design intent.

## BMAD Framework Documentation Assets

- `.github/agents/*.md` and `.github/prompts/*.md` provide BMAD agent and prompt definitions.
- `_bmad/` contains the installed BMAD framework, workflows, templates, and configuration.
- These files are important for maintaining the BMAD layer, but they are secondary to the application docs when documenting the MVC starter itself.

## Generated Documentation in This Workflow Run

- Files created under `docs/` by this workflow should be treated as generated brownfield documentation outputs, not original project-authored documents.

## Observations

- No dedicated architecture, deployment, API, or data-model markdown docs existed for the application before this workflow run.
- The README is the main human-authored source of project usage and structure.
- Most other markdown assets in the repo belong to the BMAD toolchain rather than the Classic ASP application itself.

+ 12
- 0
docs/ideas.md Näytä tiedosto

@@ -0,0 +1,12 @@
Create and agents.md and claude.md so agents can use this repo to quickly develop applications


to do :
refactor so that classes and functions are wsl components that are unregistered and reregestered at application startup in the global.asa file

we need a scrit that will turn classes and functions into wsl files that the code can call and use

need to design classes with reflection in mind so that classes know about themselves and what they can do

also need to desgin functions and methods with contract by design in mind so that errors can be trapped better


+ 71
- 0
docs/index.md Näytä tiedosto

@@ -0,0 +1,71 @@
# MVC-Starter Documentation Index

**Type:** monolith
**Primary Language:** VBScript / Classic ASP
**Architecture:** Server-rendered MVC monolith
**Last Updated:** 2026-03-11T11:59:39Z

## Project Overview

MVC-Starter is a RouteKit Classic ASP starter application for Windows IIS. It uses a single front controller, shared runtime/framework libraries, server-rendered views, an Access database, and VBScript-based scaffolding tools.

## Quick Reference

- **Tech Stack:** Classic ASP, VBScript, IIS, Access, Bootstrap
- **Entry Point:** `public/Default.asp`
- **Architecture Pattern:** Starter/framework hybrid MVC monolith
- **Database:** `db/webdata.accdb` via ACE OLE DB
- **Deployment:** Manual IIS deployment

## Generated Documentation

### Core Documentation

- [Project Overview](./project-overview.md) - Executive summary and high-level architecture
- [Project Structure](./project-structure.md) - Classification and structural boundaries
- [Source Tree Analysis](./source-tree-analysis.md) - Annotated directory structure
- [Architecture](./architecture.md) - Detailed technical architecture
- [Architecture Patterns](./architecture-patterns.md) - Runtime and design patterns
- [Technology Stack](./technology-stack.md) - Stack inventory and justification
- [Component Inventory](./component-inventory.md) - Runtime, UI, and tooling components
- [Development Guide](./development-guide.md) - Setup and common workflows
- [Deployment Guide](./deployment-guide.md) - IIS deployment and config guidance
- [API Contracts](./api-contracts-mvc-starter.md) - HTTP route contracts
- [Data Models](./data-models-mvc-starter.md) - Current data/model state and strategy

### Supporting Analysis

- [Existing Documentation Inventory](./existing-documentation-inventory.md)
- [User-Provided Context](./user-provided-context.md)
- [State Management Patterns](./state-management-patterns-mvc-starter.md)
- [UI Component Inventory](./ui-component-inventory-mvc-starter.md)
- [Comprehensive Analysis](./comprehensive-analysis-mvc-starter.md)
- [Critical Folders Summary](./critical-folders-summary.md)
- [Development Instructions](./development-instructions.md)
- [Deployment Configuration](./deployment-configuration.md)
- [Project Parts Metadata](./project-parts.json)
- [Project Scan State](./project-scan-report.json)

## Existing Documentation

- [README.md](../README.md) - Setup, structure, and feature scaffolding workflow
- [.github/copilot-instructions.md](../.github/copilot-instructions.md) - BMAD/Copilot repo instructions
- [_bmad-output/project-context.md](../_bmad-output/project-context.md) - Generated AI implementation context

## Getting Started

### For Humans

1. Read [project-overview.md](./project-overview.md)
2. Review [architecture.md](./architecture.md)
3. Use [development-guide.md](./development-guide.md) for feature work

### For AI-Assisted Development

- Start from this index
- Use [architecture.md](./architecture.md) and [project-context.md](../_bmad-output/project-context.md) together
- Reference [api-contracts-mvc-starter.md](./api-contracts-mvc-starter.md) and [data-models-mvc-starter.md](./data-models-mvc-starter.md) for route/data planning

---

Documentation generated by BMAD `document-project`.

+ 70
- 0
docs/project-overview.md Näytä tiedosto

@@ -0,0 +1,70 @@
# MVC-Starter - Project Overview

**Date:** 2026-03-11T11:59:39Z
**Type:** web
**Architecture:** Server-rendered MVC monolith

## Executive Summary

MVC-Starter is a RouteKit Classic ASP starter for building server-rendered MVC applications on Windows IIS. It combines a shared framework/runtime layer in `core/` with application-specific controllers and views in `app/`, and supports database-backed features through Access and VBScript-based scaffolding.

## Project Classification

- **Repository Type:** monolith
- **Project Type(s):** web
- **Primary Language(s):** VBScript, Classic ASP
- **Architecture Pattern:** Starter/framework hybrid MVC monolith

## Technology Stack Summary

- Runtime: Classic ASP on IIS
- Routing/dispatch: RouteKit-style router and MVC dispatcher
- Data: ADO + Microsoft Access
- UI: Bootstrap CDN + server-rendered ASP views
- Tooling: Windows Script Host VBScript scripts

## Key Features

- Front-controller request flow through `public/Default.asp`
- Controller whitelist and dynamic dispatch in `core/mvc.asp`
- Shared header/footer layout for page rendering
- Generator-assisted migrations, repositories, and controllers
- Included starter pages for home and 404 handling

## Architecture Highlights

- Single deployable web app
- Clear split between runtime/framework code and app-specific code
- Config-driven behavior through `public/web.config`
- Manual but structured development workflow through scripts and route/controller wiring

## Development Overview

### Prerequisites

- Windows + IIS + Classic ASP
- IIS URL Rewrite
- Microsoft Access Database Engine
- `cscript` for tooling

### Getting Started

Point IIS at `public/`, update `public/web.config`, then validate the home page loads. Use the provided VBScript generators to create migrations, repositories, and controllers for new features.

### Key Commands

- **Generate migration:** `cscript //nologo scripts\generateMigration.vbs create_my_table`
- **Generate repo:** `cscript //nologo scripts\GenerateRepo.vbs /table:my_table /pk:id`
- **Generate controller:** `cscript //nologo scripts\generateController.vbs MyController "Index;Show(id)"`
- **Run migrations:** `cscript //nologo scripts\runMigrations.vbs status`

## Repository Structure

`public/` is the web entry surface, `core/` is the framework/runtime layer, `app/` is the application layer, `db/` contains database assets, and `scripts/` contains operational tooling.

## Documentation Map

- [index.md](./index.md)
- [architecture.md](./architecture.md)
- [source-tree-analysis.md](./source-tree-analysis.md)
- [development-guide.md](./development-guide.md)

+ 26
- 0
docs/project-parts.json Näytä tiedosto

@@ -0,0 +1,26 @@
{
"repository_type": "monolith",
"parts": [
{
"part_id": "mvc-starter",
"part_name": "MVC-Starter",
"root_path": "/workspace/MVC-Starter",
"project_type_id": "web",
"runtime_shape": "server-rendered-mvc-monolith",
"hosting_assumption": "Windows IIS with URL Rewrite",
"entry_point": "public/Default.asp",
"framework_runtime_path": "core/",
"application_surface_path": "app/",
"operational_support_paths": [
"db/",
"scripts/"
],
"primary_technologies": [
"Classic ASP",
"VBScript",
"IIS",
"Microsoft Access"
]
}
]
}

+ 1
- 0
docs/project-scan-report.json Näytä tiedosto

@@ -0,0 +1 @@
{"workflow_version":"1.2.0","timestamps":{"started":"2026-03-11T11:59:39Z","last_updated":"2026-03-11T12:13:30Z","completed":"2026-03-11T12:13:30Z"},"mode":"initial_scan","scan_level":"exhaustive","project_root":"/workspace/MVC-Starter","project_knowledge":"/workspace/MVC-Starter/docs","completed_steps":[{"step":"step_1","status":"completed","timestamp":"2026-03-11T12:03:40Z","summary":"Classified as monolith with 1 part; detected Classic ASP MVC web application hosted via IIS entrypoint in public/Default.asp"},{"step":"step_2","status":"completed","timestamp":"2026-03-11T12:06:06Z","summary":"Inventoried 3 relevant existing documentation files and recorded no additional user focus areas"},{"step":"step_3","status":"completed","timestamp":"2026-03-11T12:09:06Z","summary":"Analyzed technology stack and architecture pattern as Classic ASP/VBScript MVC monolith on IIS with Access and VBScript tooling"},{"step":"step_4","status":"completed","timestamp":"2026-03-11T12:12:40Z","summary":"Completed exhaustive conditional analysis and generated API, data, state, UI, and comprehensive analysis documents"},{"step":"step_5","status":"completed","timestamp":"2026-03-11T12:12:55Z","summary":"Generated source tree analysis and critical folders summary"},{"step":"step_6","status":"completed","timestamp":"2026-03-11T12:13:05Z","summary":"Generated development instructions and deployment configuration documentation"},{"step":"step_8","status":"completed","timestamp":"2026-03-11T12:13:10Z","summary":"Generated architecture.md for the single application part"},{"step":"step_9","status":"completed","timestamp":"2026-03-11T12:13:15Z","summary":"Generated supporting overview, component, development, deployment, and index-adjacent docs"},{"step":"step_10","status":"completed","timestamp":"2026-03-11T12:13:20Z","summary":"Generated master index with complete links and no incomplete markers"},{"step":"step_11","status":"completed","timestamp":"2026-03-11T12:13:25Z","summary":"Validated generated docs, found no incomplete documentation markers"},{"step":"step_12","status":"completed","timestamp":"2026-03-11T12:13:30Z","summary":"Workflow complete"}],"current_step":"completed","findings":{"project_classification":"monolith, 1 part, Classic ASP/VBScript web application","existing_documentation":"3 relevant docs found; README, Copilot instructions, and generated project context","technology_stack":"Classic ASP/VBScript on IIS with Access, RouteKit-style MVC runtime, Bootstrap CDN, and VBScript tooling","batch_summaries":["Application routes, controllers, views, and shared layout documented from app/ and public/","Runtime and framework behavior documented from core/","Database and operational tooling documented from db/ and scripts/"]},"project_types":[{"part_id":"mvc-starter","project_type_id":"web","display_name":"web"}],"outputs_generated":["project-scan-report.json","project-structure.md","project-parts.json","existing-documentation-inventory.md","user-provided-context.md","technology-stack.md","architecture-patterns.md","api-contracts-mvc-starter.md","data-models-mvc-starter.md","state-management-patterns-mvc-starter.md","ui-component-inventory-mvc-starter.md","comprehensive-analysis-mvc-starter.md","source-tree-analysis.md","critical-folders-summary.md","development-instructions.md","deployment-configuration.md","architecture.md","project-overview.md","component-inventory.md","development-guide.md","deployment-guide.md","index.md"],"resume_instructions":"Workflow complete. Start a fresh scan only if the project changes materially.","verification_summary":"Exhaustive file-system scan of app/core/public/scripts/db; extracted runtime config, routes, controllers, views, and tooling docs; checked docs for incomplete markers; no IIS runtime tests executed.","open_risks":"Documentation is based on static code/config analysis in this Linux workspace; Windows IIS runtime behavior, Access connectivity, and script execution were not validated live.","next_checks":"Review docs/index.md, validate the app on a Windows IIS host, confirm web.config paths, and regenerate docs after adding real models/repositories/migrations."}

+ 38
- 0
docs/project-structure.md Näytä tiedosto

@@ -0,0 +1,38 @@
# MVC-Starter Project Structure

**Date:** 2026-03-11T11:59:39Z
**Repository Type:** monolith
**Detected Project Type:** web
**Specific Runtime Shape:** Classic ASP server-rendered MVC starter on Windows IIS
**Primary Technologies:** Classic ASP, VBScript, IIS, Microsoft Access

## Classification Summary

This repository is a single deployable web application, not a multi-part client/server system. It is a server-rendered Classic ASP MVC starter with:

- `public/` as the IIS web root and deploy entrypoint
- `core/` as shared framework/runtime code
- `app/` as the application extension surface for controllers, views, models, and repositories
- `db/` as database and migration support
- `scripts/` as scaffolding and operational tooling

## Detected Part

### MVC-Starter

- **Root Path:** `/workspace/MVC-Starter`
- **Project Type:** web
- **Runtime Shape:** Server-rendered MVC monolith
- **Hosting Assumption:** Windows IIS with URL Rewrite
- **Deploy Entry Point:** `public/Default.asp`
- **Framework Runtime:** `core/`
- **Application Extension Surface:** `app/`
- **Operational Support Directories:** `db/`, `scripts/`

## Why This Classification Fits

- The repository exposes a single web entrypoint through `public/Default.asp` and IIS rewrite config in `public/web.config`.
- Request handling flows through `public/` into framework code in `core/`, while application behavior is implemented in `app/`.
- Request handling, view rendering, routing, data access, and framework runtime are all contained in one application tree.
- There are no separate client/server packages, independent deployables, or service boundaries that would justify multi-part classification.
- The repo structure matches a classic server-rendered MVC application rather than a frontend/backend split web stack.

+ 100
- 0
docs/source-tree-analysis.md Näytä tiedosto

@@ -0,0 +1,100 @@
# MVC-Starter - Source Tree Analysis

**Date:** 2026-03-11T11:59:39Z

## Overview

The repository is organized as a Classic ASP MVC starter with a clear split between deploy entry, shared runtime, application code, database assets, and operational tooling.

## Complete Directory Structure

```text
MVC-Starter/
├── app/ # Application-specific MVC layer
│ ├── controllers/ # Controllers and controller includes
│ ├── models/ # Intended POBO/model location (currently empty)
│ ├── repositories/ # Intended repository location (currently empty)
│ └── views/ # Server-rendered ASP views
│ ├── Error/
│ ├── Home/
│ └── shared/
├── core/ # Framework/runtime libraries and dispatcher
├── db/ # Database file and future migrations
│ ├── migrations/
│ └── webdata.accdb
├── docs/ # Generated brownfield documentation
├── public/ # IIS web root and request entrypoint
│ ├── Default.asp
│ └── web.config
├── scripts/ # Scaffolding and migration tooling
├── _bmad/ # Installed BMAD framework assets
├── _bmad-output/ # Generated BMAD workflow artifacts
└── .github/ # Copilot/BMAD prompt and agent support files
```

## Critical Directories

### `public/`

Purpose: deploy-facing web root and request bootstrap.

- Contains the front controller `Default.asp`
- Contains `web.config` with rewrite and runtime config
- Entry point for all non-static requests

### `core/`

Purpose: shared framework/runtime layer.

- Contains dispatcher, router, controller registry, helpers, DAL, migrations, flash helpers, and utility libraries
- High-blast-radius area for architectural changes

### `app/`

Purpose: project-specific extension surface.

- `controllers/` contains active controllers and include registration
- `views/` contains page templates and shared layout files
- `models/` and `repositories/` are intended generator targets

### `db/`

Purpose: database storage and schema evolution support.

- Includes `webdata.accdb`
- Includes `migrations/` directory for migration files

### `scripts/`

Purpose: development and operations support tooling.

- Controller generator
- Repository/POBO generator
- Migration generator
- Migration runner

## Entry Points

- Main request entry: `public/Default.asp`
- Runtime bootstrap: `core/autoload_core.asp`
- MVC dispatcher: `core/mvc.asp`
- Migration tooling entry: `scripts/runMigrations.vbs`

## Configuration Files

- `public/web.config` - IIS routing and runtime application settings
- `README.md` - setup and workflow guidance
- `.github/copilot-instructions.md` - BMAD/Copilot workflow guidance for repo maintenance

## File Organization Patterns

- Request handling starts in `public/`, not `app/`
- Shared reusable runtime code lives in `core/`
- Feature-specific behavior belongs in `app/`
- Operational scripts live outside the runtime in `scripts/`
- Generated documentation is isolated under `docs/`

## Development Notes

- This structure assumes IIS deployment with `public/` as the site root.
- Future application growth is expected to add controllers, views, models, repositories, and migrations without changing the overall directory shape.

+ 26
- 0
docs/state-management-patterns-mvc-starter.md Näytä tiedosto

@@ -0,0 +1,26 @@
# State Management Patterns - MVC-Starter

**Date:** 2026-03-11T11:59:39Z

## Overview

This project does not implement client-side application state management in the SPA sense. State is primarily handled on the server/request side through controller properties, request data, and helper libraries.

## Observed Patterns

- **Request-scoped flow:** Incoming requests are routed and dispatched per request through `public/Default.asp` and `core/mvc.asp`.
- **Controller-held page state:** Controllers expose simple properties such as `useLayout` and `Title` to influence rendering behavior.
- **Flash messaging:** Shared layout calls `Flash().ShowErrorsIfPresent` and `Flash().ShowSuccessIfPresent`, indicating transient server-side UI messaging.
- **Configuration-driven behavior:** Runtime flags and UI behavior are sourced from `public/web.config` via `GetAppSetting`.
- **Form/cache helpers available:** `core/lib.FormCache.asp` and related helpers suggest server-side request/form support patterns.

## What Is Not Present

- No Redux, Context API, Vuex, MobX, Zustand, or similar client-state library
- No SPA store layer
- No separate API/client state synchronization layer

## Brownfield Notes

- Treat this app as server-rendered and request-driven.
- If richer client-side interactivity is added later, it will be a new architectural layer rather than an extension of an existing state-management system.

+ 28
- 0
docs/technology-stack.md Näytä tiedosto

@@ -0,0 +1,28 @@
# Technology Stack

**Date:** 2026-03-11T11:59:39Z

## Part: MVC-Starter

| Category | Technology | Version / Variant | Justification |
|---|---|---|---|
| Runtime | Classic ASP | legacy IIS-hosted runtime | Request entrypoint is `public/Default.asp`, with `.asp` controllers, views, and framework files across `app/` and `core/`. |
| Language | VBScript | Classic ASP server-side VBScript | Controllers, framework code, helpers, and operational scripts are written in VBScript. |
| Web Server | IIS | Windows IIS with URL Rewrite | `public/web.config` configures default document behavior and rewrite rules to route requests through `Default.asp`. |
| MVC Framework | RouteKit Classic ASP | project-local framework/starter | README identifies RouteKit Classic ASP; routing and dispatch are implemented by `router.wsc`, `core/mvc.asp`, and controller registry logic. |
| Routing | RouteKit router + IIS rewrite | custom runtime routing | `router.AddRoute` is used in `public/Default.asp`, and incoming requests are rewritten by IIS before dispatch. |
| Data Access | ADO / OLE DB | Classic ASP ADODB stack | DAL and repository generation rely on ADO connections and Classic ASP data access libraries. |
| Database | Microsoft Access | `Microsoft.ACE.OLEDB.12.0` provider | `public/web.config` configures an `.accdb` connection string; `db/webdata.accdb` is included in the repo. |
| Database Migration | Custom VBScript migration runner | project-local | `scripts/runMigrations.vbs` manages migration application, rollback, and status outside IIS. |
| UI Framework | Bootstrap | 5.3.3 | Shared header loads Bootstrap CSS and JS from CDN for layout and components. |
| Icon Library | Bootstrap Icons | 1.11.3 | Shared header loads Bootstrap Icons from CDN. |
| Frontend Rendering | Server-rendered HTML views | Classic ASP include-based rendering | Controllers include `.asp` view files, with shared header/footer layout wrapping page content. |
| Tooling | Windows Script Host VBScript scripts | project-local generators | `scripts/generateController.vbs`, `GenerateRepo.vbs`, `generateMigration.vbs`, and `runMigrations.vbs` drive scaffolding and DB workflow. |
| Configuration | IIS `web.config` + appSettings | XML-based runtime config | Connection strings, environment flags, cache settings, flash timing, and other behavior are driven from `public/web.config`. |

## Stack Notes

- This is a server-rendered web app, not a separate frontend/backend split stack.
- The repo has no `package.json`, `requirements.txt`, or other modern package manifest for the application itself.
- Frontend assets are primarily CDN-hosted Bootstrap resources plus local static assets served from `public/`.
- Development and operational tooling assume a Windows environment with IIS and Windows Script Host.

+ 50
- 0
docs/ui-component-inventory-mvc-starter.md Näytä tiedosto

@@ -0,0 +1,50 @@
# UI Component Inventory - MVC-Starter

**Date:** 2026-03-11T11:59:39Z

## Overview

The current UI surface is small and server-rendered. Reuse is primarily achieved through shared layout files and Bootstrap utility/component classes rather than a formal component library.

## Shared UI Surfaces

### Shared Layout

- `app/views/shared/header.asp`
- Sets page charset/codepage
- Resolves the page title from `CurrentController.Title`
- Loads Bootstrap 5.3.3 and Bootstrap Icons 1.11.3 from CDN
- Renders the top navigation shell
- Displays flash error/success messages

- `app/views/shared/footer.asp`
- Closes the main layout wrapper
- Loads the Bootstrap JS bundle from CDN

## Feature Views

### Home View

- `app/views/Home/index.asp`
- Welcome/placeholder landing page
- Uses Bootstrap cards, grid, typography, and code snippets
- Documents where new controllers, repositories, and views belong

### Error View

- `app/views/Error/NotFound.asp`
- 404 page with countdown redirect behavior
- Uses Bootstrap card layout and iconography
- Reads redirect timing from config via `GetAppSetting("Error404RedirectSeconds")`

## Reusable UI Patterns

- Shared header/footer layout wrapping
- Bootstrap-based cards and grid layout
- Config-driven flash messages in shared layout
- Simple server-rendered page title convention via controller property

## Brownfield Notes

- Reuse is currently layout-oriented, not component-library oriented.
- New UI work will likely create additional `.asp` view files under `app/views/` rather than reusable frontend components in a JS framework.

+ 13
- 0
docs/user-provided-context.md Näytä tiedosto

@@ -0,0 +1,13 @@
# User-Provided Context

**Date:** 2026-03-11T11:59:39Z

No additional documents, paths, or focus areas were provided by the user for this documentation run.

## Implication for This Scan

The scan should prioritize:

- the main application structure under `public/`, `core/`, `app/`, `db/`, and `scripts/`
- existing first-party guidance in `README.md`
- BMAD-related project instructions only where they affect project understanding or AI-assisted maintenance

+ 42
- 0
public/Default.asp Näytä tiedosto

@@ -0,0 +1,42 @@
<!--#include file="..\core\autoload_core.asp" -->

<%
' Define starter application routes
router.AddRoute "GET", "/home", "TodayController", "Index"
router.AddRoute "GET", "/", "TodayController", "Index"
router.AddRoute "GET", "", "TodayController", "Index"
router.AddRoute "GET", "/404", "ErrorController", "NotFound"

' Today (follow-up queue)
router.AddRoute "GET", "/today", "TodayController", "Index"

' Dashboard (counts)
router.AddRoute "GET", "/dashboard", "DashboardController", "Index"

' Businesses
router.AddRoute "GET", "/businesses", "BusinessesController", "Index"
router.AddRoute "GET", "/businesses/:id", "BusinessesController", "Show"
router.AddRoute "POST", "/businesses/:id/update", "BusinessesController", "Update"
router.AddRoute "POST", "/businesses/:id/log", "BusinessesController", "Log"
router.AddRoute "POST", "/businesses/:id/remove", "BusinessesController", "Remove"
router.AddRoute "POST", "/businesses/:id/restore", "BusinessesController", "Restore"

' Industries
router.AddRoute "GET", "/industries", "IndustriesController", "Index"
router.AddRoute "POST", "/industries/create", "IndustriesController", "Create"
router.AddRoute "POST", "/industries/:id/rename", "IndustriesController", "Rename"
router.AddRoute "POST", "/industries/:id/merge", "IndustriesController", "Merge"
router.AddRoute "POST", "/industries/:id/delete", "IndustriesController", "Delete"

' Export (CSV download)
router.AddRoute "GET", "/export/businesses", "ExportController", "Businesses"

' Import
router.AddRoute "GET", "/import", "ImportController", "Index"
router.AddRoute "POST", "/import/upload", "ImportController", "Upload"
router.AddRoute "POST", "/import/run", "ImportController", "Run"

' Dispatch the request (resolves route and executes controller action)
MVC.DispatchRequest Request.ServerVariables("REQUEST_METHOD"), _
TrimQueryParams(Request.ServerVariables("HTTP_X_ORIGINAL_URL"))
%>

+ 70
- 0
public/web.config Näytä tiedosto

@@ -0,0 +1,70 @@
<?xml version="1.0" encoding="UTF-8"?>
<configuration>

<appSettings>
<!--
Access connection string.
IMPORTANT: Change Data Source to the real physical path
to your webdata.accdb file.
-->
<add key="ConnectionString"
value="Provider=Microsoft.ACE.OLEDB.16.0;Data Source=D:\Development\ASP CLASSIC\Prospecting\db\webdata.accdb;Persist Security Info=False;" />

<!-- Environment flag (Development / Staging / Production) -->
<add key="Environment" value="Development" />

<!-- Flash message display duration in milliseconds -->
<add key="FlashMessageTimeout" value="3000" />

<!-- 404 error page redirect countdown in seconds -->
<add key="Error404RedirectSeconds" value="5" />

<!-- Cache expiration year for static content -->
<add key="CacheExpirationYear" value="2030" />

<!-- Maximum characters to display in table cells before truncating -->
<add key="TableCellMaxLength" value="90" />

<!-- Character threshold for textarea vs input field in forms -->
<add key="FormTextareaThreshold" value="100" />

<!-- Enable error logging to file (true/false) -->
<add key="EnableErrorLogging" value="false" />

<!-- Error log file path (if EnableErrorLogging is true) -->
<add key="ErrorLogPath" value="D:\Development\ASP CLASSIC\Prospecting\logs\errors.log" />

<!-- Enable cache-busting for URLs and assets (true/false) -->
<add key="EnableCacheBusting" value="false" />

<!-- Cache-bust parameter name (default: "v") -->
<add key="CacheBustParamName" value="v" />
</appSettings>

<system.webServer>
<!-- Default document for the site root -->
<defaultDocument>
<files>
<clear />
<add value="Default.asp" />
</files>
</defaultDocument>

<!-- URL Rewrite: send everything through Default.asp except static assets -->
<rewrite>
<rules>
<rule name="Rewrite to Default.asp" stopProcessing="true">
<match url="^(?!Default\.asp$|css/|js/|images/|aspunit/|favicon\.ico$).*$" />

<conditions>
<add input="{REQUEST_FILENAME}" matchType="IsFile" negate="true" />
<add input="{REQUEST_FILENAME}" matchType="IsDirectory" negate="true" />
</conditions>

<action type="Rewrite" url="/Default.asp" />
</rule>
</rules>
</rewrite>
</system.webServer>

</configuration>

+ 4
- 0
run_site.cmd Näytä tiedosto

@@ -0,0 +1,4 @@
@echo off
setlocal
set "ASPC_STARTER_ROOT=%~dp0"
"C:\Program Files (x86)\IIS Express\iisexpress.exe" /config:"%~dp0applicationhost.config"

+ 637
- 0
scripts/GenerateRepo.vbs Näytä tiedosto

@@ -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 <appSettings>,
' discovers [table] schema, and generates:
' � POBO_<Table>.asp (Classic ASP class with typed Property Lets)
' � <Table>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:<TableName> /pk:<PrimaryKey> [/cs:<ConnStringKey>] [/config:<PathToWebConfig>]"
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_<Table>.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 <Table>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

+ 69
- 0
scripts/createDatabase.vbs Näytä tiedosto

@@ -0,0 +1,69 @@
'=======================================================================================================================
' CREATE DATABASE (Standalone VBScript, ADOX)
'=======================================================================================================================
' Creates a new, empty Access (.accdb) database using ADOX.
'
' Usage:
' cscript //nologo scripts\createDatabase.vbs [path] [/force]
'
' Defaults to db\webdata.accdb under the project root. Refuses to overwrite an existing file unless /force is given.
' Requires the Microsoft Access Database Engine (ACE OLEDB 12.0 or 16.0) matching the bitness of cscript.exe.
'
Option Explicit

Dim fso, scriptDir, projectRoot, dbPath, force, i, arg
Dim providers, p, cat, created, lastErr

Set fso = CreateObject("Scripting.FileSystemObject")
scriptDir = fso.GetParentFolderName(WScript.ScriptFullName)
projectRoot = fso.GetAbsolutePathName(scriptDir & "\..")
dbPath = projectRoot & "\db\webdata.accdb"
force = False

For i = 0 To WScript.Arguments.Count - 1
arg = WScript.Arguments(i)
If LCase(arg) = "/force" Then
force = True
Else
dbPath = fso.GetAbsolutePathName(arg)
End If
Next

If fso.FileExists(dbPath) Then
If Not force Then
WScript.Echo "Error: " & dbPath & " already exists. Use /force to overwrite."
WScript.Quit 1
End If
fso.DeleteFile dbPath, True
End If

If Not fso.FolderExists(fso.GetParentFolderName(dbPath)) Then
fso.CreateFolder fso.GetParentFolderName(dbPath)
End If

providers = Array("Microsoft.ACE.OLEDB.16.0", "Microsoft.ACE.OLEDB.12.0")
created = False
lastErr = ""

For Each p In providers
On Error Resume Next
Set cat = CreateObject("ADOX.Catalog")
cat.Create "Provider=" & p & ";Data Source=" & dbPath & ";"
If Err.Number = 0 Then
created = True
Else
lastErr = p & ": " & Err.Description
End If
Err.Clear
On Error GoTo 0
Set cat = Nothing
If created Then
WScript.Echo "Created " & dbPath & " using " & p
Exit For
End If
Next

If Not created Then
WScript.Echo "Error: could not create database. " & lastErr
WScript.Quit 1
End If

+ 320
- 0
scripts/deploy-iis-git.ps1 Näytä tiedosto

@@ -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 }
}

BIN
scripts/generateController.vbs Näytä tiedosto


+ 162
- 0
scripts/generateMigration.vbs Näytä tiedosto

@@ -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

Some files were not shown because too many files changed in this diff

Loading…
Peruuta
Tallenna

Powered by TurnKey Linux.