#!/usr/bin/wapptclsh
#
# This script implements a simple URL shortener backed by an SQLite database.
#
# For administrative access, this script must be invoked via the
# Fossil CGI extension mechanism:
#
#    https://fossil-scm.org/home/doc/trunk/www/serverext.wiki
#
# That is because administrative access uses the FOSSIL_CAPABILITIES and
# FOSSIL_USER environment variables.  However, for ordinary shortener
# redirects, this routine can be run as an ordinary CGI.  So the intended
# use case is:
#
#     1.  Set up a CGI (perhaps called just "/u") on the website to act
#         as the normal redirect site.
#
#     2.  Set up a separate CGI (at something like "/fossil/ext/urlshortener")
#         uses the same database as (1) and serving as the administration
#         point for creating, editing, and deleting short URLs.
#
#
########
#
#  Setup:
set BASEURL                https://sqlite.org/u
set ADMIN_CAPABILITY       i
set DATABASE               /url-shortener.db
#
########
package require wapp

# Open the shortener database.  Initialize it if necessary.
#
proc open-database {} {
  global DATABASE
  sqlite3 db $DATABASE
  db eval {
    CREATE TABLE IF NOT EXISTS url(
      name TEXT PRIMARY KEY,
      redir TEXT,
      user TEXT,
      ctime DATE,
      mtime DATE,
      notes TEXT
    ) WITHOUT ROWID;
  }
}

# Debugging: show the environment
proc wapp-page-env {} {
  wapp-allow-xorigin-params
  wapp-trim {
    <h1>Wapp Environment</h1>
    <pre>%html([wapp-debug-env])</pre>
  }
}

# Issue the "Not Found" page
proc wapp-page-notfound {} {
  wapp-reply-code "404 Not Found"
  wapp-trim {
    <h1>Not Found</h1>
    <p>No such resource:
    "%html%([wapp-param BASE_URL])%%html%([wapp-param PATH_INFO])%"</p>
  }
}

# Do a redirect
proc wapp-default {} {
  set x [wapp-param PATH_HEAD {}]
  if {$x==""} {
    wapp-page-search
    return
  }
  open-database
  set redir [db one {SELECT redir FROM url WHERE name=$x}]
  if {$redir==""} {
    wapp-page-notfound
    return
  }
  wapp-redirect $redir
}

# Check credentials.  Return true to abort because credentials
# are invalid.
#
proc check-credentials {} {
  global ADMIN_CAPABILITY env
  if {![info exists env(FOSSIL_CAPABILITIES)]} {
    wapp-page-notfound
    return 1
  }
  return 0
}

# Search for an existing entry
#
proc wapp-page-search {} {
  if {[check-credentials]} return
  set base [wapp-param BASE_URL]
  wapp-trim {
    <h1>Admin URL Shortener At %html%($::DATABASE)%</h1>
    <p><a href="%url($base)/editentry">Create-New-URL</a>
    <p>
    <form>
    Search: <input type="text" size="60" name="s">
    <input type="submit" name="s1" value="Go">
    </form>
  }
  if {[wapp-param-exists s]} {
    set s [wapp-param s]
    wapp-trim {
      <h2>Search results for %html($s):</h2><ol>
    }
    open-database
    set pattern %$s%
    set cnt 0
    db eval {
      SELECT name, redir FROM url 
       WHERE name LIKE $pattern OR redir LIKE $pattern
    } {
      wapp-trim {
        <li><a href="%url($base)/editentry/%url($name)">%html($name)</a>
      }
      incr cnt
    }
    wapp-trim {</ol>}
    if {$cnt==0} {
      wapp-trim {
        <p>No matches found</p>
      }
    }
  }
}

# Create or edit a new URL shortener entry.
#
# Name of the entry to be editted is in PATH_TAIL.  Or if PATH_TAIL is
# blank, create a new entry.
#
proc wapp-page-editentry {} {
  global BASEURL
  if {[check-credentials]} return
  if {[wapp-param-exists cancel]} {
    wapp-redirect [wapp-param BASEURL]/search
    return
  }
  open-database
  set hardname [wapp-param PATH_TAIL {}]
  set name [wapp-param name $hardname]
  set redir [wapp-param redir {}]
  set notes [wapp-param notes {}]
  wapp-trim {
    <head></head>
    <body>
  }
  set errmsg {}
  if {[wapp-param-exists s1]} {
    if {$hardname==""} {
      set e [db one {SELECT count(*) FROM url WHERE name=$name}]
      if {$e==1} {
        set errmsg "Shortened URL name "$name" already exists.\
        Pick a different name."
      } elseif {[string length $name]<4} {
        set errmsg "Shortened URL name "$name" too short.\
                    Must be at least 4 characters."
      } elseif {[regexp {[^a-z0-9]} $name]} {
        set errmsg "Shortened URL name "$name" contains invalid characters. \
          The name must be lower-case ASCII letters and digits only."
      } else {
        set user $::env(FOSSIL_USER)
        db eval {
          INSERT INTO url(name,redir,user,notes,ctime,mtime)
          VALUES($name,$redir,$user,$notes,datetime(),datetime())
        }
        set hardname $name
      }
    } else {
      db eval {
        UPDATE url SET redir=$redir, notes=$notes, mtime=datetime()
         WHERE name=$name
      }
    }
  }
  set ctime {}
  set user {}
  set mtime {}
  if {$hardname==""} {
    wapp-trim {
      <h1>Create A New Shortened URL</h1>
    }
    if {$errmsg!=""} {
      wapp-trim {
        <p style='color:red;'>%html($errmsg)</p>
      }
    }
    wapp-trim {
      <form method="POST">
      <table border="0" cellpadding="0" cellspacing="10">
      <tr>
      <td align="right">Shortened-URL:</td>
      <td>%html($BASEURL)/<input type="text" name="name" value="%html($name)" size="10">
      </tr>
    }
  } else {
    wapp-trim {
      <h1>Edit Shortened URL: %html($BASEURL)/%html($hardname)</h1>
      <form method="POST">
      <input type="hidden" name="name" value="%html($hardname)">
      <table border="0" cellpadding="0" cellspacing="10">
      <tr>
      <td align="right">Shortened-URL:</td>
      <td>%html($BASEURL)/%html($hardname)
      </tr>
    }
    db eval {
      SELECT ctime, mtime, user, redir, notes FROM url WHERE name=$name
    } break
    set redir [wapp-param redir $redir]
    set notes [wapp-param notes $notes]
  }
  wapp-trim {
    <tr>
    <td align="right">Redirect-To:</td>
    <td><input type="text" name="redir" value="%html($redir)" size="70"></td>
    </tr>
  }
  if {$ctime!=""} {
    if {$user==""} {set user ???}
    wapp-trim {
      <tr><td align="right">Created:</td>
      <td>%html($ctime) by %html($user)</td></tr>
    }
  }
  if {$mtime!="" && $mtime!=$ctime} {
    wapp-trim {
      <tr><td align="right">Modified:</td><td>%html($ctime)</td></tr>
    }
  }
  wapp-trim {
    <tr>
    <td align="right">Notes:</td>
    <td><input type="text" name="notes" value="%html($notes)" size="70"></td>
    </tr>
    <tr>
    <td>&nbsp</td>
    <td><input type="submit" name="s1" value="Submit">
    <input type="submit" name="cancel" value="Cancel">
    </tr>
    </table>
    </form>
  }
}

wapp-start $argv
