Created
February 29, 2012 12:22
-
-
Save smiler/1940454 to your computer and use it in GitHub Desktop.
SML web chat
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| (************************************************************************** | |
| * File : inl2.sml | |
| * Project : Inlämningsuppgift 2 | |
| * Author : Christian Axelsson | |
| * Created : 2005-12-27 | |
| * Description : Webchat | |
| **************************************************************************) | |
| (* | |
| load "TextIO"; load "Random"; load "Time"; load "Mosmlcgi"; load "Mosmlcookie"; | |
| *) | |
| (* | |
| Konfiguration | |
| ============= | |
| *) | |
| val sessionLength = 3600 (* Hur länge en session varar. *) | |
| val userfile = "users.db" (* Var användare lagras. *) | |
| val sessionfile = "sessions.db" (* Var sessioner lagras. *) | |
| val postfile = "posts.db" (* Var meddelanden lagras. *) | |
| val maxposts = 10 (* Maximalt antal poster som skall sparas. *) | |
| (* | |
| ================== | |
| Slut konfiguration | |
| *) | |
| open Mosmlcgi; | |
| open Mosmlcookie; | |
| (* TYPE: inputType | |
| Dom olika alternativen för type-fältet i XHTMLs <input>-tag. | |
| Se standarden för XHTML för mer info. | |
| *) | |
| datatype inputTypes = TEXT | |
| | PASSWORD | |
| | TEXTAREA | |
| | SUBMIT | |
| | HIDDEN; | |
| (* TYPE: session | |
| Beskriver en session för användaren user som utgår efter expire med | |
| identifieraren id. | |
| *) | |
| type session = { user : string, expire : Date.date, id : string }; | |
| (* TYPE: user | |
| Beskriver en användare med användarnamnet name och lösenordet password. | |
| *) | |
| type user = { name : string, password : string }; | |
| (* TYPE: post | |
| Beskriver ett meddelande i chatten där user är användaren som postat, time | |
| är tidpunkten då meddelandet postades, ip är den IP-address användaren hade | |
| när han postade och message är meddelandet. | |
| *) | |
| type post = { user : string, time : Date.date, ip : string, message : string } | |
| (* printPage (title, header, body) | |
| TYPE : string option * string * string * string -> unit | |
| PRE : (inget) | |
| POST : (inget) | |
| SIDE-EFFECTS : En HTML-sida med titeln title, överskriften header och | |
| kroppen body. Om extraheaders inte är NONE skickas | |
| valOf(extraheaders) med som HTTP-headers. | |
| *) | |
| fun printPage (extraheaders, title, header, body) = | |
| print((if extraheaders = NONE then | |
| "Content-type: text/html\n\n" | |
| else | |
| valOf extraheaders ^ "\nContent-type: text/html\n\n") ^ | |
| "<?xml version=\"1.0\" encoding=\"ISO-8859-1\" ?>" ^ | |
| "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"" ^ | |
| " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" ^ | |
| "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"sv\">\n" ^ | |
| " <head>\n" ^ | |
| " <title>" ^ title ^ "</title>" ^ | |
| " </head>\n" ^ | |
| " <body>\n" ^ | |
| " <div id=\"header\">\n" ^ | |
| " <h1>" ^ header ^ "</h1>\n" ^ | |
| " </div>\n" ^ | |
| body ^ "\n" ^ | |
| " </body>\n" ^ | |
| "</html>\n"); | |
| (* makeErrorPage msg | |
| TYPE : string -> string | |
| PRE : (inget) | |
| POST : HTML-kod som beskriver ett felmeddelande specifierat av msg | |
| *) | |
| fun makeErrorPage msg = "<div id=\"errorPage\">\n" ^ | |
| " <p>" ^ msg ^ "</p>\n" ^ | |
| "</div>"; | |
| (* makeForm (id, form, submit) | |
| TYPE : string -> string | |
| PRE : (inget) | |
| POST : HTML-kod för form som ett formulär med id id som skickas | |
| till submit | |
| EXAMPLES : makeForm("form", | |
| "<input type=\"text\" name=\"namn\">" ^ | |
| "<input type=\"submit\" value=\"Skicka\">", "") = | |
| "<form method=\"post\" action=\"\">\n | |
| <div id=\"form\"> | |
| <input type=\"text\" name=\"namn\"> | |
| <input type=\"submit\" value=\"Skicka\"> | |
| </div> | |
| </form>\n" | |
| *) | |
| fun makeForm (id, form, submit) = | |
| "<form method=\"post\" action=\"" ^ submit ^ "\">\n<div id=\"" ^ id ^ "\">" | |
| ^ form ^ "</div></form>\n"; | |
| (* makeInput (intype, name, value) | |
| TYPE : string * string * string option -> string | |
| PRE : name <= 1 tecken | |
| POST : En inputbox med namnet name och som är av typen intype. | |
| Om value är SOME({value}) får det inputboxen innehållet som | |
| är specifierat av valOf(value) annars inget innehåll. | |
| EXAMPLES : makeInput(TEXTAREA, "message", NONE) = | |
| "<textarea name=\"message\" id=\"message\" | |
| rows=\"5\" cols=\"35\"> | |
| </textarea>" | |
| makeInput(HIDDEN, "secret", SOME("topsecret")) = | |
| "<input type=\"hidden\" name=\"secret\" | |
| id=\"secret\" value=\"topsecret\" />" | |
| *) | |
| fun makeInput (TEXTAREA, name, value) = | |
| "<textarea name=\"" ^ name ^ "\" id=\"" ^ name ^ | |
| "\" rows=\"5\" cols=\"35\">" ^ | |
| (if Option.isSome value then | |
| valOf value | |
| else | |
| "") ^ "</textarea>" | |
| | makeInput (intype, name, value) = | |
| let | |
| val input = case intype of | |
| TEXT => "text" | |
| | PASSWORD => "password" | |
| | SUBMIT => "submit" | |
| | HIDDEN => "hidden" | |
| | TEXTAREA => "Why cant mosml combine patternmatching" ^ | |
| "in fun and case? Crap :(" | |
| in | |
| "<input type=\"" ^ input ^ "\" name=\"" ^ name ^ "\" " ^ | |
| "id=\"" ^ name ^ "\" " ^ | |
| (if Option.isSome value then | |
| "value=\"" ^ valOf value ^ "\" />" | |
| else | |
| "/>") | |
| end; | |
| (* makeFrontPage () | |
| TYPE : unit -> string | |
| PRE : (inget) | |
| POST : HTML-kod för en sida där användare kan logga in. | |
| *) | |
| fun makeFrontPage () = | |
| "<div id=\"body\">\n" ^ | |
| makeForm("loginForm", | |
| "<label for=\"username\">Namn:</label>" ^ | |
| makeInput(TEXT, "username", NONE) ^ "<br />\n" ^ | |
| "<label for=\"password\">Lösenord:</label>" ^ | |
| makeInput(PASSWORD, "password", NONE) ^ "<br />\n" ^ | |
| makeInput(SUBMIT, "submit", SOME("Logga in")) ^ "\n" ^ | |
| "<!-- UGLY HACK BECAUSE MOSMLLIB DOSESN'T SUPPORT" ^ | |
| "PULLING INFO FROM GET AND POST AT THE SAME TIME -->\n" | |
| ^ makeInput(HIDDEN, "a", SOME("login")), | |
| valOf cgi_script_name ^ "?a=login") ^ | |
| "<br />\n" ^ "Om du inte har någon användare klicka " ^ | |
| "<a href=\"" ^ valOf cgi_script_name ^ "?a=register\">här</a>" | |
| ^ "</div>"; | |
| (* makeRegistrationPage () | |
| TYPE : unit -> string | |
| PRE : (inget) | |
| POST : HTML-kod för ett forumlär där användare kan registrera sig. | |
| *) | |
| fun makeRegistrationPage () = | |
| makeForm("registrationForm", | |
| "<label for=\"username\">Namn:" ^ | |
| makeInput(TEXT, "username", NONE) ^ "<br />\n" ^ | |
| "<label for=\"password\">Lösenord:" ^ | |
| makeInput(PASSWORD, "password", NONE) ^ "<br />\n" ^ | |
| makeInput(SUBMIT, "submit", SOME("Registrera")) ^ "\n" ^ | |
| makeInput(HIDDEN, "a", SOME("register")), | |
| valOf cgi_script_name ^ "?a=register"); | |
| (* makeRegisterdPage () | |
| TYPE : unit -> string | |
| PRE : (inget) | |
| POST : HTML-kod för en sida som talar om att användaren har blivit | |
| registrerad. | |
| *) | |
| fun makeRegisterdPage () = "Klicka <a href=\"" ^ valOf cgi_script_name ^ "\">" | |
| ^ "här</a> för att logga in."; | |
| (* makeWrongUserPassPage () | |
| TYPE : unit -> string | |
| PRE : (inget) | |
| POST : HTML-kod för en sida som talar om att användaren har skrivit | |
| in en felaktig kombination av användarnamn och lösenord. | |
| *) | |
| fun makeWrongUserPassPage () = | |
| makeErrorPage("Du skrev in ett felaktikt användarnamn eller lösenord.<br>\n" | |
| ^"Klicka <a href=\"" ^ valOf cgi_script_name ^ "\">här</a>" ^ | |
| " för att försöka igen eller " ^ | |
| "<a href=\"" ^ valOf cgi_script_name ^ "?a=register\">här</a>" | |
| ^ " om du vill registrera en ny användare."); | |
| local | |
| (* dbToList is | |
| TYPE : instream -> string list list | |
| PRE : (inget) | |
| POST : Varje kommaseprarerad sträng i is på varje rad blir ett | |
| element i den inre listan. | |
| SIDE-EFFECTS : Alla tecken i is läses in. is stängs. | |
| *) | |
| (* VARIANT : Antal tecken i is *) | |
| fun dbToList is = | |
| let | |
| (* readLine is | |
| TYPE : instream -> string option | |
| PRE : (inget) | |
| POST : SOME(Första raden i is) utan "\n" ifall det finns | |
| minst 1 tecken i is annars NONE. | |
| SIDE-EFFECTS : Alla tecken fram tom."\n" eller EOF läses in från is. | |
| Läspekaren i is flyttas fram lika många tecken som | |
| lästs in ifrån is. | |
| *) | |
| fun readLine is = if TextIO.endOfStream is then | |
| NONE | |
| else | |
| let | |
| val s = TextIO.inputLine is | |
| in | |
| SOME(String.substring(s, 0, | |
| String.size s - 1)) | |
| end; | |
| val row = readLine is | |
| in | |
| if Option.isSome row then | |
| String.fields (fn c => c = #",") (valOf row) :: dbToList is | |
| else | |
| (TextIO.closeIn is; []) | |
| end | |
| in | |
| (* sessionsToList () | |
| TYPE : unit -> session list | |
| PRE : Filen specifierad av sessionfile är läsbara. | |
| POST : Alla sessioner i databasen sessionfile | |
| SIDE-EFFECTS : Filen specifierad av sessionfile öppnas. | |
| *) | |
| fun sessionsToList () = | |
| let | |
| (* sessionsToList' l | |
| TYPE : string list list -> session list | |
| PRE : Varje element i l innehåller 3 element. | |
| Det första elementet skall motsvara det första fältet | |
| i sessionfile, det andra det andra fältet och det | |
| trejde det tredje fältet. | |
| POST : l som en lista av sessioner. | |
| *) | |
| fun sessionsToList' [] = [] | |
| | sessionsToList' (head::tail) = {id = List.nth(head, 2), | |
| user = List.nth(head, 1), | |
| expire = valOf(Date.fromString( | |
| List.nth(head, 0)))} :: | |
| sessionsToList' tail | |
| in | |
| sessionsToList'(dbToList(TextIO.openIn sessionfile)) | |
| end | |
| (* usersToList () | |
| TYPE : unit -> user list | |
| PRE : Filen specifierad av userfile är läsbar. | |
| POST : Alla användare i databasen userfile. | |
| SIDE-EFFECTS : Filen specifierad av userfile öppnas. | |
| *) | |
| fun usersToList () = | |
| let | |
| (* usersToList' l | |
| TYPE : string list list -> user list | |
| PRE : Varje element i l innehåller 2 element. | |
| Det första elementet skall motsvara det första fältet | |
| i userfile och det andra det andra fältet. | |
| POST : l som en lista av användare | |
| *) | |
| fun usersToList' [] = [] | |
| | usersToList' (head::tail) = {name = List.nth(head, 0), | |
| password = List.nth(head, 1)} :: | |
| usersToList' tail | |
| in | |
| usersToList'(dbToList(TextIO.openIn userfile)) | |
| end | |
| (* postsToList () | |
| TYPE : unit -> post list | |
| PRE : Filen specifiead av postfile är läsbar. | |
| POST : Alla poster i databasen postfile. | |
| SIDE-EFFECTS : Filen specifierad av postfile öppnas. | |
| *) | |
| fun postsToList () = | |
| let | |
| (* postsToList' l | |
| TYPE : string list list -> post list | |
| PRE : Varje element i l innehåller 4 element. | |
| Det första elementet skall motsvara det första fältet | |
| i postsfile, det andra det andra fältet, det tredje | |
| det treje fältet och det fjärde det fjärde fältet. | |
| POST : l som en lista av poster | |
| *) | |
| fun postsToList' [] = [] | |
| | postsToList' (head::tail) = {user = List.nth(head, 1), | |
| time = valOf(Date.fromString( | |
| List.nth(head, 0))), | |
| ip = List.nth(head, 2), | |
| message = List.nth(head, 3)} :: | |
| postsToList' tail | |
| in | |
| postsToList'(dbToList(TextIO.openIn postfile)) | |
| end | |
| end; | |
| (* writeSessions sessionList | |
| TYPE : session list -> unit | |
| PRE : Filen specifierad av sessionfile är skrivbar. | |
| POST : (inget) | |
| SIDE-EFFECTS : Filen specifierad av sessionfile öppnas, skrivs till och | |
| stängs. | |
| *) | |
| fun writeSessions sessionList = | |
| let | |
| val os = TextIO.openOut sessionfile | |
| in | |
| ((List.app (fn ({user : string, expire : Date.date, id : string}) => | |
| TextIO.output(os, Date.toString expire ^ "," ^ | |
| user ^ "," ^ | |
| id ^ "\n")) sessionList); | |
| TextIO.flushOut os; TextIO.closeOut os) | |
| end; | |
| (* writeUsers userList | |
| TYPE : user list -> unit | |
| PRE : Filen specifierad av userfile är skrivbar. | |
| POST : (inget) | |
| SIDE-EFFECTS : Filen specifierad av userfile öppnas, skrivs till och stängs. | |
| *) | |
| fun writeUsers userList = | |
| let | |
| val os = TextIO.openOut userfile | |
| in | |
| ((List.app (fn ({name : string, password : string}) => | |
| TextIO.output(os, name ^ "," ^ password ^ "\n")) | |
| userList); | |
| TextIO.flushOut os; TextIO.closeOut os) | |
| end; | |
| (* writePosts postList | |
| TYPE : post list -> unit | |
| PRE : Filen specifierad av postfile är skrivbar | |
| POST : (inget) | |
| SIDE-EFFECTS : Filen specifierad av postfile öppnas, skrivs till och stängs. | |
| *) | |
| fun writePosts postList = | |
| let | |
| val os = TextIO.openOut postfile | |
| in | |
| ((List.app (fn ({user : string, | |
| time : Date.date, | |
| ip : string, | |
| message : string}) => | |
| TextIO.output(os, Date.toString time ^ "," ^ | |
| user ^ "," ^ | |
| ip ^ "," ^ | |
| message ^ "\n")) postList); | |
| TextIO.flushOut os; TextIO.closeOut os) | |
| end; | |
| (* getCookieUserValue () | |
| TYPE : unit -> string option | |
| PRE : (inget) | |
| POST : SOME("användarnamn") om det finns en cookie satt med namnet | |
| "user" annars NONE | |
| *) | |
| fun getCookieUserValue () = getCookieValue("user"); | |
| (* getCookieSessionValue () | |
| TYPE : unit -> string option | |
| PRE : (unit) | |
| POST : SOME("sessionid") om det finns en cookie satt med namnet | |
| "sessionid" annars NONE | |
| *) | |
| fun getCookieSessionValue () = getCookieValue("sessionid"); | |
| (* makeChatPage () | |
| TYPE : unit -> string | |
| PRE : (inget) | |
| POST : HTML-kod för att visa webchatten | |
| *) | |
| fun makeChatPage () = | |
| let | |
| val user = valOf(getCookieUserValue()); | |
| (* makeBody l | |
| TYPE : string list list -> string | |
| PRE : l är en lista som beskriver en post-databas | |
| POST : En HTML-formatterad text som innehåller alla poster | |
| i webchatten. | |
| *) | |
| (* VARIANT : Antal element i l *) | |
| fun makeBody [] = "" | |
| | makeBody ({ip : string, message : string, time : Date.date, | |
| user : string} :: tail) = | |
| "\n<h2>Postat av " ^ user ^ " (" ^ ip ^ ") " ^ | |
| Date.toString time ^ "</h2>\n<p>" ^ message ^ "\n</p>\n" ^ | |
| makeBody tail | |
| in | |
| let | |
| val body = "<div id=\"posts\">" ^ | |
| makeBody(postsToList()) ^ | |
| "</div>" | |
| val input = makeForm("postForm", | |
| makeInput(TEXTAREA, "post", | |
| SOME("Skriv ditt meddelande här")) | |
| ^ "<br />\n" ^ makeInput(SUBMIT, "Skicka", | |
| SOME("Skicka")) | |
| ^ makeInput(HIDDEN, "a", SOME("post")), | |
| valOf cgi_script_name ^ "?a=chat") | |
| in | |
| if body = "" then | |
| "<hr />" ^ "Det finns inga poster." ^ "<hr />" ^ input | |
| else | |
| "<hr />" ^ body ^ "<hr />" ^ input | |
| end | |
| end; | |
| (* cleanOldSessions () | |
| TYPE : unit -> unit | |
| PRE : (inget) | |
| POST : (inget) | |
| *) | |
| fun cleanOldSessions () = | |
| let | |
| (* validSessions sessionList | |
| TYPE : session list -> session list | |
| PRE : (inget) | |
| POST : En lista med alla giltiga sessioner. | |
| (För betydelsen av vad en giltig session är se | |
| dokumentationen om sessionfile) | |
| *) | |
| (* VARIANT : Antal element i sessionList *) | |
| fun validSessions [] = [] | |
| | validSessions ({user : string, expire : Date.date, id : string} | |
| ::tail) = | |
| if Date.compare(expire, Date.fromTimeLocal(Time.now())) = LESS then | |
| validSessions tail | |
| else | |
| {user = user , expire = expire, id = id} :: validSessions tail | |
| in | |
| writeSessions(validSessions(sessionsToList())) | |
| end; | |
| (* getSessionID user | |
| TYPE : string -> string option | |
| PRE : (inget) | |
| POST : Om användaren user har en session i databasen returneras | |
| SOME("sid") där "sid" är det sessionsid user har. | |
| *) | |
| fun getSessionID username = | |
| let | |
| fun getSessionID' [] = NONE | |
| | getSessionID' ({user : string, id : string, expire : Date.date} | |
| ::tail) = | |
| if username = user then | |
| SOME(id) | |
| else | |
| getSessionID' tail | |
| in | |
| getSessionID'(sessionsToList()) | |
| end; | |
| (* deleteSession username | |
| TYPE : string -> unit | |
| PRE : (inget) | |
| POST : (inget) | |
| SIDE-EFFECTS : Om användaren username finns i sessionfile tas denna rad bort | |
| ur sessionfile. | |
| *) | |
| fun deleteSession username = | |
| writeSessions(List.filter (fn ({user : string, expire : Date.date, | |
| id : string}) => not(user = username)) | |
| (sessionsToList())) | |
| (* updateSession username | |
| TYPE : string -> unit | |
| PRE : (inget) | |
| POST : (inget) | |
| SIDE-EFFECTS : Om användaren username finns i sessionfile uppdateras | |
| expire-fältet i sessionfile till nu + en timme. | |
| *) | |
| fun updateSession username = | |
| let | |
| (* update sessionList | |
| TYPE : session list -> session list | |
| PRE : (inget) | |
| POST : Varje element i sessionList med expire-fältet | |
| uppdaterat till nu + en timme. | |
| *) | |
| fun update [] = [] | |
| | update ({user : string, expire : Date.date, id : string}::tail) = | |
| if user = username then | |
| {user = user, | |
| expire = Date.fromTimeLocal(Time.+(Time.now(), | |
| Time.fromSeconds | |
| sessionLength)), | |
| id = id} :: update tail | |
| else | |
| {user = user, expire = expire, id = id} :: update tail | |
| in | |
| writeSessions(update(sessionsToList())) | |
| end | |
| (* makeSession user | |
| TYPE : string -> string option | |
| PRE : Filen sessionfile finns och är läs- och skrivbar. | |
| POST : SOME(En cookie som kan användas för att verifiera att | |
| användaren user är inloggad) ifall det inte redan | |
| existerar en session för användaren user, annars NONE. | |
| SIDE-EFFECTS : En session för användaren user läggs till i filen | |
| specifierad av userfile. | |
| *) | |
| fun makeSession user = | |
| let | |
| (* randomString n | |
| TYPE : int -> string | |
| PRE : (inget) | |
| POST : n antal tecken som är slumpade i intervallen a-z, | |
| A-Z och 0-9 | |
| *) | |
| fun randomString n = | |
| let | |
| val gen = Random.newgen() | |
| fun makeRandom 0 = "" | |
| | makeRandom n = makeRandom(n - 1) ^ | |
| str(Char.chr(Random.range(List.nth( | |
| [(48,57), | |
| (65,90), | |
| (97,122)], | |
| Random.range(0, 3) | |
| gen)) | |
| gen)) | |
| in | |
| makeRandom n | |
| end | |
| val sid = (cleanOldSessions(); getSessionID user) | |
| in | |
| if Option.isSome sid andalso sid = getCookieSessionValue() then | |
| (updateSession user; NONE) | |
| else | |
| let | |
| val sessionid = randomString 16 | |
| val now = Time.now() | |
| val ts = Time.fmt 0 now | |
| val sessioncookie = setCookie{name = "sessionid", | |
| value = sessionid, | |
| expiry = NONE, | |
| domain = NONE, | |
| path = NONE, | |
| secure = false} | |
| val usercookie = setCookie{name = "user", | |
| value = user, | |
| expiry = NONE, | |
| domain = NONE, | |
| path = NONE, | |
| secure = false} | |
| val expire = Date.fromTimeLocal(Time.+(now, | |
| Time.fromSeconds 3600)) | |
| in | |
| (writeSessions({user = user, expire = expire, id = sessionid} | |
| :: sessionsToList()); | |
| SOME(usercookie ^ "\n" ^ sessioncookie)) | |
| end | |
| end; | |
| (* checkSession (username, sessionid) | |
| TYPE : string * string -> bool | |
| PRE : (inget) | |
| POST : true om användaren username som har en session i sessionfile | |
| som har id sessionid annars false | |
| SIDE-EFFECTS : Inaktuella sessioner rensas bort ur sessionfile. | |
| *) | |
| fun checkSession (username, sessionid) = | |
| let | |
| (* checkSession' sessionList | |
| TYPE : session list -> bool | |
| PRE : (inget) | |
| POST : true om användaren username har en giltig session i | |
| sessionList som har id sessionsid annars false. | |
| *) | |
| fun checkSession' [] = false | |
| | checkSession' ({user : string, expire : Date.date, id : string} | |
| ::tail) = if user = username andalso | |
| sessionid = id then | |
| true | |
| else | |
| checkSession' tail | |
| in | |
| (cleanOldSessions(); checkSession'(sessionsToList())) | |
| end; | |
| (* checkAuth (user, pass) | |
| TYPE : string * string -> bool | |
| PRE : (inget) | |
| POST : true om användaren user har lösenordet pass i userfile annars | |
| false. | |
| *) | |
| fun checkAuth (user, pass) = | |
| Option.isSome(List.find (fn ({name : string, password : string}) => | |
| user = name andalso pass = password) | |
| (usersToList())) | |
| (* doRegistration (user, pass) | |
| TYPE : string * string -> string option | |
| PRE : user innehåller >= 3 tecken | |
| pass innehåller >= 6 tecken | |
| user och pass innehåller bara tecknen a-z, A-Z och 0-9 | |
| POST : NONE ifall registreringen lyckades. | |
| SOME("Användarnamnet är för kort") ifall användarnamnet | |
| user < 3 tecken. | |
| SOME("Lösenordet för kort") ifall pass < 6 tecken. | |
| SOME("Användarnamnet och lösenordet får bara innehålla | |
| a-z, A-Z och 0-9") ifall user eller pass innehåller | |
| något felaktigt tecken. | |
| SIDE-EFFECTS : Om POST är NONE läggs användaren user till i filen | |
| specifierad av userfile med lösenordet pass. | |
| *) | |
| fun doRegistration (user, pass) = | |
| let | |
| (* isAlNum s | |
| TYPE : string -> bool | |
| PRE : (inget) | |
| POST : true om s bara innehåller tecknen a-z, A-Z eller 0-9 | |
| *) | |
| fun isAlNum "" = true | |
| | isAlNum s = if Char.isAlphaNum(String.sub(s, String.size s - 1)) | |
| then | |
| isAlNum(String.substring(s, 0, String.size s - 1)) | |
| else | |
| false | |
| val currentUsers = usersToList() | |
| in | |
| if (String.size user) < 3 then | |
| SOME("Användarnamnet är för kort") | |
| else if (String.size pass) < 6 then | |
| SOME("Lösenordet är för kort") | |
| else if not(isAlNum user) orelse not(isAlNum pass) then | |
| SOME("Användarnamnet och lösenordet får bara innehålla " ^ | |
| "a-z, A-Z och 0-9") | |
| else if Option.isSome(List.find (fn ({name : string, | |
| password : string}) => | |
| name = user) | |
| currentUsers) then | |
| SOME("Användarnamnet " ^ user ^ " är redan upptaget") | |
| else | |
| (writeUsers({name = user, password = pass} :: currentUsers); NONE) | |
| end; | |
| (* doPost (user, ip, message) | |
| TYPE : string * string -> unit | |
| PRE : user är en giltig användare, ip är IP-numret användaren user | |
| har. | |
| POST : (inget) | |
| SIDE-EFFECTS : En post av användaren user, ip-numret IP och med meddelandet | |
| message, läggs till i filen specifierad av postfile. | |
| Om det finns fler poster i filen specifierad av postfile än | |
| maxfiles trunkeras dom sista posterna tills det finns exakt | |
| maxfiles poster kvar. | |
| *) | |
| fun doPost (user, ip, message) = | |
| let | |
| (* escapeString s | |
| TYPE : string -> string | |
| PRE : (inget) | |
| POST : s med alla förekomster av: | |
| "<" utbytt mot "<" | |
| ">" utbytt mot ">" | |
| "&" utbytt mot "&" | |
| "\"" utbytt mot """ | |
| "'" utbytt mot "'" | |
| "å" utbytt mot "å" | |
| "Å" utbytt mot "Å" | |
| "ä" utbytt mot "ä" | |
| "Ä" utbytt mot "Ä" | |
| "ö" utbytt mot "ö" | |
| "Ö" utbytt mot "Ö" | |
| "\n" utbytt mot "<br />" | |
| "," utbytt mot "," | |
| *) | |
| (* VARIANT : Antal tecken i s *) | |
| fun escapeString "" = "" | |
| | escapeString s = | |
| (case String.sub(s, 0) of | |
| #"<" => "<" | |
| | #">" => ">" | |
| | #"&" => "&" | |
| | #"\"" => """ | |
| | #"'" => "'" | |
| | #"å" => "å" | |
| | #"Å" => "Å" | |
| | #"ä" => "ä" | |
| | #"Ä" => "Ä" | |
| | #"ö" => "ö" | |
| | #"Ö" => "Ö" | |
| | #"\n" => "<br />" (* Bevara datastrukturen i postfile *) | |
| | #"," => "," (* Samma som ovanstående *) | |
| | _ => String.substring(s, 0, 1)) ^ | |
| escapeString(String.substring(s, 1, String.size s - 1)) | |
| (* nthFirst (n, l) | |
| TYPE : int * 'a list -> 'a list | |
| PRE : n <= 0 | |
| POST : Dom n första elementen i l. Om n <= än antal element | |
| i l returneras hela l. | |
| *) | |
| (* VARIANT : n och antal element i l *) | |
| fun nthFirst (0, _) = [] | |
| | nthFirst (_, []) = [] | |
| | nthFirst (n, head::tail) = head :: nthFirst(n - 1, tail) | |
| in | |
| writePosts({user = user, ip = ip, | |
| time = Date.fromTimeLocal(Time.now()), | |
| message = escapeString message} :: | |
| nthFirst(maxposts, postsToList())) | |
| end; | |
| (* main () | |
| TYPE : unit -> unit | |
| PRE : (inget) | |
| POST : (inget) | |
| SIDE-EFFECTS : Visar en lämplig HTML-sida beroende på användarens input | |
| *) | |
| fun main () = | |
| let | |
| val action = cgi_field_string("a"); | |
| in | |
| if Option.isSome action then | |
| case valOf action of | |
| "register" => let | |
| val username = cgi_field_string("username") | |
| val password = cgi_field_string("password") | |
| in | |
| if Option.isSome username andalso | |
| Option.isSome password then | |
| let | |
| val status = doRegistration( | |
| valOf username, | |
| valOf password) | |
| in | |
| if Option.isSome status then | |
| printPage( | |
| NONE, | |
| "WebChat -> Error", | |
| "Ett fel har uppstått", | |
| makeErrorPage(valOf status)) | |
| else | |
| printPage( | |
| NONE, | |
| "WebChat -> Registrerad", | |
| "Registreringen lyckades", | |
| makeRegisterdPage()) | |
| end | |
| else | |
| printPage(NONE, | |
| "WebChat -> Registrering", | |
| "Registrering", | |
| makeRegistrationPage()) | |
| end | |
| | "login" => let | |
| val username = cgi_field_string("username") | |
| val password = cgi_field_string("password") | |
| in | |
| if Option.isSome username andalso | |
| Option.isSome password then | |
| let | |
| val user = valOf username | |
| val pass = valOf password | |
| in | |
| if checkAuth(user, pass) then | |
| printPage(makeSession(user), | |
| "WebChat -> Chat", | |
| "Välkommen " ^ user, | |
| makeChatPage()) | |
| else | |
| printPage( | |
| NONE, | |
| "WebChat -> Inloggningen " ^ | |
| "misslyckades", | |
| "Felaktigt användarnamn och/eller" | |
| ^ "lösenord", | |
| makeWrongUserPassPage()) | |
| end | |
| else | |
| printPage( | |
| NONE, | |
| "WebChat -> Inloggningen misslyckades", | |
| "Felaktigt användarnamn och/eller " ^ | |
| "lösenord", | |
| makeWrongUserPassPage()) | |
| end | |
| | "chat" => let | |
| val user = getCookieUserValue() | |
| val sessionid = getCookieSessionValue() | |
| in | |
| if Option.isSome user andalso | |
| Option.isSome sessionid then | |
| let | |
| val usr = valOf user | |
| in | |
| if checkSession(usr, valOf sessionid) | |
| then | |
| printPage(NONE, | |
| "WebChat -> Chat", | |
| "Välkommen " ^ usr, | |
| makeChatPage()) | |
| else | |
| printPage( | |
| NONE, | |
| "WebChat -> Error", | |
| "Ett fel har uppstått", | |
| makeErrorPage("Du är inte " ^ | |
| "inloggad.")) | |
| end | |
| else | |
| printPage( | |
| NONE, | |
| "WebChat -> Error", | |
| "Ett fel har uppstått", | |
| makeErrorPage("Din session är inte" ^ | |
| "giltigt, var god logga " ^ | |
| "in på nytt")) | |
| end | |
| | "post" => let | |
| val user = getCookieUserValue() | |
| val sessionid = getCookieSessionValue() | |
| val message = cgi_field_string("post") | |
| in | |
| if Option.isSome user andalso | |
| Option.isSome sessionid andalso | |
| checkSession(valOf user, valOf sessionid) | |
| then | |
| if Option.isSome message then | |
| let | |
| val msg = valOf message | |
| val usr = valOf user | |
| in | |
| if String.size msg >= 2 then | |
| (doPost( | |
| usr, | |
| valOf cgi_remote_addr, | |
| msg); | |
| printPage(NONE, | |
| "WebChat -> Chat", | |
| "Välkommen " ^ usr, | |
| makeChatPage())) | |
| else | |
| printPage( | |
| NONE, | |
| "WebChat -> Error", | |
| "Ett fel har uppstått", | |
| makeErrorPage( | |
| "Ditt meddelande är " ^ | |
| "för kort. " ^ | |
| "Gå tillbaka och " ^ | |
| "försök igen.")) | |
| end | |
| else | |
| printPage( | |
| NONE, | |
| "WebChat -> Error", | |
| "Ett fel har uppstått", | |
| makeErrorPage("Felaktigt " ^ | |
| "meddelande. " ^ | |
| "Gå tillbaka, " ^ | |
| "kontrollera och " ^ | |
| "försök igen.")) | |
| else | |
| printPage( | |
| NONE, | |
| "WebChat -> Error", | |
| "Ett fel har uppstått", | |
| makeErrorPage("Din session är inte" ^ | |
| "giltig, var god logga" ^ | |
| "in på nytt")) | |
| end | |
| | _ => printPage(NONE, | |
| "WebChat -> Inloggning", | |
| "Logga in för att använda webchatten", | |
| makeFrontPage()) | |
| else | |
| printPage(NONE, | |
| "WebChat -> Inloggning", | |
| "Logga in för att använda webchatten", | |
| makeFrontPage()) | |
| end; | |
| val _ = main(); |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment