Increase domain component length limit

[hcoop/zz_old/portal.git] / init.sml

diff --git a/init.sml b/init.sml
index 2b2df7b..c56044b 100644 (file)
--- a/init.sml
+++ b/init.sml
@@ -1,20 +1,17 @@
 structure Init :> INIT =
 struct
 
-open Util Sql
+open Util Sql Config
 structure C = PgClient
 
 exception Access of string
 exception NeedTos
 
-val urlPrefix = "http://users.hcoop.net/portal/"
-val boardEmail = "board.fake@hcoop.net"
-
-fun conn () = C.conn "dbname='hcoop'"
+fun conn () = C.conn dbstring
 val close = C.close
 
 type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp,
-            app : int}
+            app : int, shares : int}
 
 val db = ref (NONE : C.conn option)
 val user = ref (NONE : user option)
@@ -29,10 +26,10 @@ fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs
 
 fun getDb () = valOf (!db)
 
-fun mkUserRow [id, name, rname, bal, joined, app] =
+fun mkUserRow [id, name, rname, bal, joined, app, shares] =
     {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
      bal = C.intFromSql bal, joined = C.timestampFromSql joined,
-     app = C.intFromSql app}
+     app = C.intFromSql app, shares = C.intFromSql shares}
   | mkUserRow row = rowError ("user", row)
 
 fun init () =
@@ -46,8 +43,8 @@ fun init () =
        case Web.getCgi "REMOTE_USER" of
            NONE => raise Fail "Not logged in"
          | SOME name =>
-           (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app
-                                    FROM WebUser
+           (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares
+                                    FROM WebUserActive
                                     WHERE name=^(C.stringToSql name)`) of
                 NONE => raise Fail "User not found"
               | SOME r =>
@@ -87,12 +84,12 @@ fun getUserId () = #id (getUser ())
 fun getUserName () = #name (getUser ())
 
 fun lookupUser id =
-    mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app
+    mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares
                                      FROM WebUser
                                      WHERE id = ^(C.intToSql id)`))
 
 fun listUsers () =
-    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app
+    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares
                                  FROM WebUser
                                  ORDER BY name`)
 
@@ -101,13 +98,14 @@ fun nextSeq (db, seq) =
        [id] => C.intFromSql id
       | _ => raise Fail "Bad next sequence val"
 
-fun addUser (name, rname, bal, app) =
+fun addUser (name, rname, bal, app, shares) =
     let
        val db = getDb ()
        val id = nextSeq (db, "WebUserSeq")
     in
-       C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app)
-                   VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP, ^(C.intToSql app))`);
+       C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares)
+                   VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal),
+                           CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares))`);
        id
     end
 
@@ -117,16 +115,25 @@ fun modUser (user : user) =
     in
        ignore (C.dml db ($`UPDATE WebUser SET
                            name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
-                              bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user))
+                              bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)),
+                              shares = ^(C.intToSql (#shares user))
                            WHERE id = ^(C.intToSql (#id user))`))
     end
 
+fun byPledge () =
+    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares
+                                 FROM WebUser
+                                 WHERE shares > 1
+                                 ORDER BY shares DESC`)    
+
 fun deleteUser id =
     C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
 
 fun validUsername name =
     size name <= 10
-    andalso CharVector.all Char.isAlpha name
+    andalso size name > 0
+    andalso Char.isLower (String.sub (name, 0))
+    andalso CharVector.all Char.isAlphaNum name
 
 fun userNameToId name =
     case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
@@ -153,7 +160,7 @@ fun grandfatherUsers () =
                ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other,
                                                        passwd, status, applied, confirmed, decided, msg)
                                 VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname),
-                                        NULL, '^name@hcoop.net', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
+                                        NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
                                         'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP,
                                         CURRENT_TIMESTAMP, 'GRANDFATHERED')`));
                ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`))
@@ -161,4 +168,4 @@ fun grandfatherUsers () =
     in
        C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
     end
-end
\ No newline at end of file
+end