Doing Bad Cookie Authentication, but for the Right Reasons

18 April 2018 EBrown Blog (0)

Poor Cookie-Based Authentication with ASP.NET

Greetings everyone. Once again, it's been a while since I've posted anything. I've been swamped with work, personal issues, and then some. I got a new dog (hi Max!), and so on. Fortunately, I have a topic I want to talk about (you can probably guess based on the title what it is), and thanks to a friend of mine, who we'll call "Jim" becasue, well, that's his name, who asked about this on Twitter, I figured we could go all-in.

Disclaimer: I'm a rambler, and this was hastily written.

Jim was asking about cookie-based authentication in ASP.NET, which is a great topic because it's something you should absolutely never do, but we are going to do to help him demonstrate how such a thing can be used for test automation. (Jim is a VERY smart person, and is working up a demo on how we can use cookie authentication hand-in-hand with test automation to do a wide-variety of things. The idea is to allow a test client to authenticate itself to quickly and easily get into the application.) We're going to spend this whole blog-post going over a worst-practice, vs. a best-practice. We're going to do all the things I always say never do, and learn why. (There's a lot of reasons we should not do any of these things, I'll try to cover a few with some examples.)

Then, at the end, I'm going to show you how we could do this type of authentication easily and via some sort of API call, so that we could stick with the core authentication principles that we value, and also satisfy our testers. This will demonstrate where the testers and the developers should be able to work together, to develop a flow that works for both.

We're going to build this out in Visual Studio, as usual, and we'll go over how we can take a blank ASP.NET website and add cookie-based authentication. Typically, we would use Forms-based authentication, or Active Directory / Windows Authentication.

What is a cookie?

A cookie is a small (usually) piece of information that a users browser stores which allows them to carry and pass information to and from a website. This cookie is a piece of data that is sent client-to-server, and server-to-client. We use cookies to transfer non-confidential data, because cookies are incredibly insecure. Anyone can spoof a cookie, and we'll look at doing exactly that in this blog post as well.

Cookie-Based Authentication in ASP.NET

Alright, so let's go ahread and create some cookie-based authentication in our ASP.NET application. For this, we'll have three pages:

Default.aspx: the main landing page, visible to authenticated and unauthenticated users;
Login.aspx: the login page, this will test the user login and create an appropriate cookie;
Authenticated.aspx: a page only available to authenticated users;

Step 1: Create the `Authenticated.aspx`

This page is pretty basic markup-wise (even code-wise):

<%@ Page Language="C#" AutoEventWireup="true" CodeBehind="Authenticated.aspx.cs" Inherits="Poor_Cookie_Authentication__17_4_2018_.Authenticated" %>

<!DOCTYPE html>

<html xmlns="http://www.w3.org/1999/xhtml">
<head runat="server">
    <title></title>
</head>
<body>
    <form id="form1" runat="server">
        <div>
            Hello <asp:Literal runat="server" ID="litUserName"></asp:Literal>!
        </div>
        <div>
            This page is only available to authenticated users.
        </div>
    </form>
</body>
</html>

Basically, we throw a single literal which will be the name of the authenticated user. We'll populate this from the code-behind file, which is also really simple. But, before we do the code-behind, let's build a user object.

I'm going to do extremely basic authentication: our User class will have a Username (email) and Password. It will also contain a static array of all eligible users, so as to allow us to "pretend" to log someone in. We'll create two sample users, with different passwords:

public class User
{
    public static User[] Users { get; } =
        new[]
        {
            new User() { Username = "ebrown@example.com", Password = "1234" },
            new User() { Username = "johndoe@example.com", Password = "5678" }
        };

    public string Username { get; private set; }
    public string Password { get; private set; }
}

This can be replaced with any type of user loading, but I kept it simple to allow easy demonstration.

Now, let's load the user:

public partial class Authenticated : System.Web.UI.Page
{
    protected void Page_Load(object sender, EventArgs e)
    {
        if (Request.Cookies["UserId"]?.Value == null)
        {
            Response.Redirect("Login.aspx");
        }

        var userId = int.Parse(Request.Cookies["UserId"].Value);
        var user = Models.User.Users[userId];
        litUserName.Text = user.Username;
    }
}

So, if it's not apparant, cookie reading is super simple in ASP.NET: simply call Request.Cookies[name].Value, I use ?.Value to avoid the need for an additional null-check. (If the cookie doesn't exist, Request.Cookies[name] returns null instead of throwing a KeyNotFoundException like a normal dictionary would.)

Step 2: `Login.aspx`

Alright, so the next step is to allow the user to login. This is really simple, and we'll do it with a small HTML page and code-behind. The login will take a username and password, and match that to a user in the User.Users array. If we find one, set a cookie with the ID.

Markup:

<%@ Page Language="C#" AutoEventWireup="true" CodeBehind="Login.aspx.cs" Inherits="Poor_Cookie_Authentication__17_4_2018_.Login" %>

<!DOCTYPE html>

<html xmlns="http://www.w3.org/1999/xhtml">
<head runat="server">
    <title></title>
</head>
<body>
    <form id="form1" runat="server">
        <div>
            <asp:Literal runat="server" ID="litError"></asp:Literal><br />
            Username: <asp:TextBox runat="server" ID="txtUsername" TextMode="Email"></asp:TextBox><br />
            Password: <asp:TextBox runat="server" ID="txtPassword" TextMode="Password"></asp:TextBox><br />
            <asp:Button runat="server" ID="btnSubmit" OnClick="btnSubmit_Click" Text="Login" />
        </div>
    </form>
</body>
</html>

Code:

public partial class Login : System.Web.UI.Page
{
    protected void Page_Load(object sender, EventArgs e)
    {
        if (Request.Cookies["UserId"]?.Value != null)
        {
            Response.Redirect("Authenticated.aspx");
        }
    }

    protected void btnSubmit_Click(object sender, EventArgs e)
    {
        var username = txtUsername.Text;
        var password = txtPassword.Text;

        var user = Models.User.Users.FirstOrDefault(x => x.Username == username && x.Password == password);
        if (user != null)
        {
            Response.Cookies.Add(new HttpCookie("UserId", Models.User.Users.ToList().IndexOf(user).ToString()) { Expires = DateTime.Now.AddHours(8) });
            Response.Redirect("Authenticated.aspx");
        }

        litError.Text = "The username/password combination you entered does not exist.";
    }
}

There are two ways to set a cookie:

Use Response.Cookies.Add;
Directly call to Response.Cookies[name], which will create the cookie if it does not exist;

Here, I chose the former as it's clearer. We add a new response cookie, set the expiration for 8 hours from now, and then redirect the user to the Authenticated.aspx page.

Step 3: Our `Default.aspx` with logout

The last step here is to make our Default.aspx page, which is again simple, and perform our logout on this page.

Markup:

<%@ Page Language="C#" AutoEventWireup="true" CodeBehind="Default.aspx.cs" Inherits="Poor_Cookie_Authentication__17_4_2018_.Default" %>

<!DOCTYPE html>

<html xmlns="http://www.w3.org/1999/xhtml">
<head runat="server">
    <title></title>
</head>
<body>
    <form id="form1" runat="server">
        <div>
            <asp:HyperLink runat="server" ID="hlLogin" Text="Login" NavigateUrl="~/Login.aspx"></asp:HyperLink>
            <asp:LinkButton runat="server" ID="lbLogout" Text="Logout" OnClick="lbLogout_Click"></asp:LinkButton>
        </div>
    </form>
</body>
</html>

Code:

public partial class Default : System.Web.UI.Page
{
    protected void Page_Load(object sender, EventArgs e)
    {
        if (Request.Cookies["UserId"]?.Value == null)
        {
            lbLogout.Visible = false;
        }
        else
        {
            hlLogin.Visible = false;
        }
    }

    protected void lbLogout_Click(object sender, EventArgs e)
    {
        Response.Cookies["UserId"].Expires = DateTime.Now.AddDays(-1);
        Response.Redirect("Default.aspx");
    }
}

We literally have a "Login" and "Logout", which one is shown depends on whether or not the cookie is set. On logout, we set the cookie expiration to the past so that the browser will delete it, and redirect the user.

Authentication complete!

Alright, so all-in-all we're basicallly done with designing the cookie-based authentication of the application, now let's move on to the insecurities of it.

Cookie-Based Authentication Insecurities

There are literally hundreds of things we could list that are reasons to not use cookie-based authentication, but let's just go over some of the basics:

Cookies are handled entirely client-side. That means, the client must be trusted to track the entire lifetime of the cookie: value, expiration, etc., all of it is in the client's hand.
Cookies are always plain-data. That is to say, they are not secured in any manner. In a non-HTTPS environment, cookies are clearly visible on transmission from client-to-server, and server-to-client. A man-in-the-middle attack with cookies is so unbelievably easy. (Facebook used to be vulnerable to session-hijacking using this attack, and I'll pull references on that later.)
Cookies carry small amounts of data. There are limits to the size of a cookie, due to the nature of it. Because cookies are passed in the headers of a web request or response, they are limited to the maximum size of a header.

Alright, so let's exploit some cookie insecurity. We're going to do four things:

Change the expiration to keep ourselves logged in longer;
Change the user ID to log in as someone else;
Change the user ID to cause the server to error (if you place cookies into SQL this can do really bad stuff);
Create a cookie with a user ID to login without credentials;

So the first task on our to-do list is to change a cookie expiration. We set it for 8 hours, but any sufficiently skilled user (and you really don't have to be all that skilled) can alter it. In fact, if you download the EditThisCookie plugin for Opera, you can do so with a two clicks. I'm going to use this to do the rest, and I'm just going to throw all the pictures with basic captions.

Step 1: We'll Login via Opera. That "Cookie" icon is our editor.

Opera Login

Step 2: Open the cookie. We click the "Cookie" Icon and expand the cookie we want ("UserId").

Opening the Cookie

Step 3: Edit the Expiration and click the "Checkmark" to save.

Edit Expiration

As you can see, pretty easy.

Next, we'll edit the value to be someone else:

Edit Value

New Page

Now I did not relogin, I used the original login and edited who I was. That's important to remember because it demonstrates why this is insecure.

We can error the server:

Bad Cookie

And even make a new cookie without logging in:

New Cookie

Automating our Tests

Ok, on to the fun part: let's automate a login, but without ever hitting the login page or function.

This is almost too easy with .NET, we'll use the WebClient and manually send the Cookie header. To do this, I created a TestAutomation.aspx page:

<%@ Page Language="C#" AutoEventWireup="true" CodeBehind="TestAutomation.aspx.cs" Inherits="Poor_Cookie_Authentication__17_4_2018_.TestAutomation" %>

<!DOCTYPE html>

<html xmlns="http://www.w3.org/1999/xhtml">
<head runat="server">
    <title></title>
</head>
<body>
    <form id="form1" runat="server">
        <div>
            <asp:Literal runat="server" ID="litResponseData"></asp:Literal>
        </div>
    </form>
</body>
</html>

The code is trivial:

public partial class TestAutomation : System.Web.UI.Page
{
    protected void Page_Load(object sender, EventArgs e)
    {
        using (var wc = new WebClient())
        {
            wc.Headers.Add("Cookie", "UserId=1");
            litResponseData.Text = wc.DownloadString("http://localhost:60078/Authenticated.aspx");
        }
    }
}

Yes, we logged in and downloaded the Authenticated.aspx text with 5 lines of code, 2 of which were braces. By manualy sending the header, we made it too easy for us to work with.

If you comment out the wc.Headers.Add line, you'll see that it returns the login form. This is because the WebClient follows the redirects. With that line in, we get the Hello ...! message.

An Ideal World

Alright, so all of this is done to demonstrate the point of how easy it is to use cookie-based authentication, and how we can exploit it, but also the ease of which it does what we want. One of the things Jim had mentioned to me was that he wanted the ability to either turn authentication off, or some other way to allow the user to login, but without needing to do too much complex work.

Typically, in this scenario, this is where the developer and tester would work together on a solution, one of which might be a very simple API call to do login: pass a username and password, then it logs that session in. We can simulate this by accepting Username and Password query-string parameters in our Login.aspx:

public partial class Login : System.Web.UI.Page
{
    protected void Page_Load(object sender, EventArgs e)
    {
        if (Request.QueryString["Username"] != null && Request.QueryString["Password"] != null)
        {
            var username = Request.QueryString["Username"];
            var password = Request.QueryString["Password"];
            doLogin(username, password);
        }

        if (Request.Cookies["UserId"]?.Value != null)
        {
            Response.Redirect("Authenticated.aspx");
        }
    }

    protected void btnSubmit_Click(object sender, EventArgs e)
    {
        var username = txtUsername.Text;
        var password = txtPassword.Text;
        doLogin(username, password);
    }

    private void doLogin(string username, string password)
    {
        var user = Models.User.Users.FirstOrDefault(x => x.Username == username && x.Password == password);
        if (user != null)
        {
            Response.Cookies.Add(new HttpCookie("UserId", Models.User.Users.ToList().IndexOf(user).ToString()) { Expires = DateTime.Now.AddHours(8) });
            Response.Redirect("Authenticated.aspx");
        }

        litError.Text = "The username/password combination you entered does not exist.";
    }
}

So Login.aspx didn't change much, we just handle both cases now. By pushing login into a function, it made it easy to deal with the query-string based login, and the form-based login. We need to modify our TestAutomation.aspx page a little to accommodate:

<%@ Page Language="C#" AutoEventWireup="true" CodeBehind="TestAutomation.aspx.cs" Inherits="Poor_Cookie_Authentication__17_4_2018_.TestAutomation" %>

<!DOCTYPE html>

<html xmlns="http://www.w3.org/1999/xhtml">
<head runat="server">
    <title></title>
</head>
<body>
    <form id="form1" runat="server">
        <div>
            <asp:Literal runat="server" ID="litResponseData1"></asp:Literal><br /><br />
            <asp:Literal runat="server" ID="litResponseData2"></asp:Literal>
        </div>
    </form>
</body>
</html>

The code is the big change:

public partial class TestAutomation : System.Web.UI.Page
{
    protected void Page_Load(object sender, EventArgs e)
    {
        // Method 1
        using (var wc = new WebClient())
        {
            wc.Headers.Add("Cookie", "UserId=1");
            litResponseData1.Text = wc.DownloadString("http://localhost:60078/Authenticated.aspx");
        }

        // Method 2
        var cookieContainer = new CookieContainer();
        var req = WebRequest.CreateHttp("http://localhost:60078/Login.aspx?Username=ebrown@example.com&Password=1234");
        req.CookieContainer = cookieContainer;
        req.GetResponse(); // We don't need to do anything with the response

        req = WebRequest.CreateHttp("http://localhost:60078/Authenticated.aspx");
        req.CookieContainer = cookieContainer;
        var response = (HttpWebResponse)req.GetResponse();
        using (var sr = new StreamReader(response.GetResponseStream()))
        {
            litResponseData2.Text = sr.ReadToEnd();
        }
    }
}

You see the // Method 2 comment? That is the part that uses the query-string to login. It can also use a POST to a form to login, if we wanted, though that is far more complex. Due to the ASP.NET event validation, it is far easier to virtually create the UI form in that case, and submit it. Instead, what we did is query-string based to support the testers use-case, and make it easy to do the testing, while also retaining most of our security.

This project is available on GitHub and I am allowing anyone to use it to any purpose, I simply ask that if you use the project directly, throw some sort of nice message on where you found it.

Constructing an IMAP Server from Scratch - Part 2

12 March 2018 EBrown Blog (0)

Implementing Server-Side RFC 3501 (IMAP) in F# (Part 2)

Previous: Implementing Server-Side RFC 3501 (IMAP) in F# (Part 1)

Alright, so the previous blog post got us introducded to our RFC 3501 (IMAP) implementation. We looked at the basic TCP/IP stack of the architecture. Today, we're going to actually start building part of the IMAP server itself.

To start building the IMAP server, we need to start building a mock file-system. Now me, personally, I'm about keeping things as simple as possible. As a result, the mock file-server I'm building is not going to do anything fancy. We'll use a DemoFiles folder in the IMAP server for all the data, then within that folder we'll have a Configuration file, then a Message_{Id} file for each message. The Configuration file will have some basic stuff:

Password: to verify the user against on authentication;
UIDVALIDITY: that value that RFC 3501 says can never change;
NextUniqueIdentifier: the value that RFC 3501 dictates must change only when a message is received;

Next, each Message_{Id} file needs to have a few of it's own pieces:

Attributes: at least all of the following attributes:
- \Seen
- \Answered
- \Flagged
- \Deleted
- \Draft
Date/Time Received: the date and time that the message was received by the server (typically via SMTP);
Message Size: the number of 8-bit octets in the message;
Envelope Structure: the parsed header of the message;
Body Structure: the parsed body (MIME-IME) of the message;
Message Text: the text(s) in the message;

We'll worry about messages later, for now I just want to concern ourselves with the configuration, as that's the first part of implementing IMAP.

Building a Configuration File

Now we have several methods for building the configuration file: XML, JSON, INI, CSV, etc. Because I'm lazy, and because this is a sample storage system, I'm going to build it as a line-delimited file. I.e.: each line is a value in the config. (Easy to write by hand, easy to ready by hand, easy to parse with code, all-in-all, pretty easy.)

Our config file will look like:

Plaintext Password (For easy troubleshooting)
The UIDVALIDITY value (Constant)
The Next Unique Identifier value (Changes when a message comes in)

My sample configuration:

Password123
307110933
1

Building Storage Events

Using this basic configuration, we can start to modify our server to take note of file read/write. We can start modifying the IMAP server to start using some storage events.

type StorageEvents =
    { Authenticate : string * string -> User option
      GetUidValidity : User -> int
      GetNextUniqueId : User -> int }

So we can start developing some basic events here. We want to be able to tell if a user can be authenticated (take a username and password and output a Some User if it's valid, or None if not). We want to get the UIDVALIDITY value (take a User and return an int), and we want to get the next unique ID (take a User and output an int).

Now we don't really take commands from the server yet, but we can shoehorn a test or two in:

let objectToStr o = o.ToString()
let rec runClient (socket : Socket) =
    let printfn = printfn "Socket %s: %s" (socket.RemoteEndPoint.ToString())
    let user = Some { Id = "ebrown@example.com" }
    async {
        let! buffer = () |> socket.AsyncReceiveAll
        let str = buffer |> Encoding.ASCII.GetString
        sprintf "Received (%i bytes): %s" buffer.Length str |> printfn
        if str.Length = 3 && str = "BYE" then printfn "Disconnected"
        else
            let! bytesSent = [| "Hello, other world!"B |> Some; user |> Option.map (storageEvents.GetUidValidity >> objectToStr >> Seq.map byte >> Seq.toArray) |] |> Array.choose id |> Array.concat |> socket.AsyncSend
            bytesSent |> sprintf "Sent response (%i bytes)" |> printfn
            return! socket |> runClient }

We'll send back the UIDVALIDITY value every time we get a packet from a client, that should be a good proof-of-concept.

Our server itself needs to change (ever-so-slightly): type Server (storageEvents) =, this will allow us to pass the storageEvents in, and the server has no idea what or how the underlying storage mechanism works (nor does it care).

Defining the entire storage system to work is really, really trivial:

type Configuration =
    { Password : string
      UidValididty : int
      NextUniqueId : int }
let getConfig (f : string) =
    let lines = System.IO.Path.Combine(@"DemoFiles", f, @"Configuration.txt") |> System.IO.File.ReadAllLines
    { Password = lines.[0]; UidValididty = lines.[1] |> int; NextUniqueId = lines.[2] |> int }
let serverEvents = 
    { Authenticate = (fun (u, p) -> if (u |> getConfig).Password = p then Some { Id = u } else None)
      GetUidValidity = (fun u -> (u.Id |> getConfig).UidValididty)
      GetNextUniqueId = (fun u -> (u.Id |> getConfig).NextUniqueId) }

We defined a Configuration type, a function to parse it, and then created a serverEvents object to hold all the functions for working with the storage system. Our main function changes little:

use server = Server(serverEvents).Start()
Console.ReadLine() |> ignore
printfn "Closing..."
0

We just put serverEvents in now.

If we put it all together to start testing it, we'll get Received 28 bytes: Hello, other world!307110933 on the client, which proves that our storage works.

We can push this off to a Storage module, to get it out of our work-area:

module EBrown.Imap.Server.Storage
open EBrown.Imap.Core

type Configuration =
    { Password : string
      UidValididty : int
      NextUniqueId : int }
let getConfig (f : string) =
    let lines = System.IO.Path.Combine(@"DemoFiles", f, @"Configuration.txt") |> System.IO.File.ReadAllLines
    { Password = lines.[0]; UidValididty = lines.[1] |> int; NextUniqueId = lines.[2] |> int }
let getStorageEvents () = 
    { Authenticate = (fun (u, p) -> if (u |> getConfig).Password = p then Some { Id = u } else None)
      GetUidValidity = (fun u -> (u.Id |> getConfig).UidValididty)
      GetNextUniqueId = (fun u -> (u.Id |> getConfig).NextUniqueId) }

Implementing IMAP Commands

Alright, so now that we have a storage mechanism, we want to start implementing some IMAP commands and state and such.

IMAP commands are either tagged or untagged, and comprise of a command name, and possibly arguments. Thus a command would look like <TAG> <COMMANDNAME> <ARGUMENTS>, where <TAG> is either a client-generated string, or a * if the command is untagged. There are a few, basic commands, that can be implemented regardless of the state of the IMAP connection:

CAPABILITY: the capability command is tagged and has no arguments. The response should be one untagged response with a list of what capabilities are currently supported by the server, and the server should send one tagged OK response (or a tagged BAD response if the command is badly formed).
NOOP: the noop command is tagged and has no arguments. There is no specific response, but it can be used as a polling command as any command can return a status update. The server should send one tagged OK (or BAD) response after sending status update data, if appropriate.
LOGOUT: the logout command is tagged and has no arguments. The response should be one untagged BYE, and one OK or BAD.

The format of an OK response to a command is <TAG> OK <COMMANDNAME> completed.

Thus, if a client sends a a002 NOOP, the server OK response would be a002 OK NOOP completed.

With all this in mind, we can start building a command parser and generator.

The first part we need is a Tag. This is honestly quite trivial:

type Tag = | Untagged | Tagged of string
let getTag = function | Untagged -> "*" | Tagged s -> s

As commands are either tagged or untagged, this makes life really easy.

Next, we need a general generateLine, which can be used to generate any given command or response:

let joinStrings (sep : string) (sarr : string array) = System.String.Join(sep, sarr)
let generateLine tag largs name rargs =
    [|[|tag |> getTag |> Some|]; largs; [|name |> Some|]; rargs|]
    |> Array.concat
    |> Array.choose id
    |> joinStrings " "

We generalize this enough so that we can use it for any command, which makes life extremely trivial to build a generateCommand:

let generateCommand tag name args = generateLine (Tagged tag) [||] name (args |> Array.map Some)

Now we can generalize command generation, let's build a capability command:

let capability tag = generateCommand tag "CAPABILITY" [||]
let capabilityResponse tag args = [|generateLine Untagged [||] "CAPABILITY" (args |> Array.map Some); generateLine (Tagged tag) [|"OK" |> Some|] "CAPABILITY" [|"completed" |> Some|]|]

Again, we're keeping it mostly simple.

The next step is to parse a command. This will be just as easy as generation, we'll define new types and a function to handle the input.

type Command = | Capability
type InputCommand = { Tag : Tag; Command : Command }
let parseCommand (command : string) =
    let parseTag = function | "*" -> Untagged | s -> Tagged s
    let parseCommandName =
        function
        | [|"CAPABILITY"|] -> Capability |> Some
        | _ -> None
    let parts = command.Split(' ')
    parts.[1..] |> parseCommandName |> Option.map (fun c -> { Tag = parts.[0] |> parseTag; Command = c })

Again, quite simple. We parse the tag out, then we parse the command out, and return the result.

So with this, extending to add a NOOP command is really easy:

type Command = | Capability | Noop
....
let noop tag = generateCommand tag "NOOP" [||]
let noopResponse tag = [|generateLine (Tagged tag) [||] "NOOP" [|"completed" |> Some|]|]
....
let parseCommand (command : string) =
    let parseTag = function | "*" -> Untagged | s -> Tagged s
    let parseCommandName =
        function
        | [|"CAPABILITY"|] -> Capability |> Some
        | [|"NOOP"|] -> Noop |> Some
        | _ -> None
    let parts = command.Split(' ')
    parts.[1..] |> parseCommandName |> Option.map (fun c -> { Tag = parts.[0] |> parseTag; Command = c })

And now we have NOOP support.

Lastly, LOGOUT command support:

let logout tag = generateCommand tag "LOGOUT" [||]
let logoutResponse tag = [|generateLine Untagged [||] "BYE" ([|"IMAP4rev1"; "Server"; "logging"; "out"|] |> Array.map Some); generateLine (Tagged tag) [||] "LOGOUT" [|"completed" |> Some|]|]
let parseCommand (command : string) =
    let parseTag = function | "*" -> Untagged | s -> Tagged s
    let parseCommandName =
        function
        | [|"CAPABILITY"|] -> Capability |> Some
        | [|"NOOP"|] -> Noop |> Some
        | [|"LOGOUT"|] -> Logout |> Some
        | _ -> None
    let parts = command.Split(' ')
    parts.[1..] |> parseCommandName |> Option.map (fun c -> { Tag = parts.[0] |> parseTag; Command = c })

Now as we work with this, we should realize that we can actually remove most of the specific functions, and use the InputCommand for the capability, noop, and logout functions we built:

type ClientCommandName = | Capability | Noop | Logout
type ClientCommand = { Tag : Tag; Command : ClientCommandName }
let generateClientCommandName =
    function
    | Capability -> ("CAPABILITY", [||])
    | Noop -> ("NOOP", [||])
    | Logout -> ("LOGOUT", [||])
let generateClientCommand (command : ClientCommand) = command.Command |> generateClientCommandName ||> generateLine command.Tag [||]
let parseClientCommand (command : string) =
    let parseTag = function | "*" -> Untagged | s -> Tagged s
    let parseCommandName =
        function
        | [|"CAPABILITY"|] -> Capability |> Some
        | [|"NOOP"|] -> Noop |> Some
        | [|"LOGOUT"|] -> Logout |> Some
        | _ -> None
    let parts = command.Split(' ')
    parts.[1..] |> parseCommandName |> Option.map (fun c -> { ClientCommand.Tag = parts.[0] |> parseTag; Command = c })

type OkBadResult = | Ok | Bad
let getOkBad = function | Ok -> ("OK", "completed") | Bad -> ("BAD", "")
type ServerCommandName = | Capability of OkBadResult * string array | Noop of OkBadResult | Logout of OkBadResult
type ServerCommand = { Tag : Tag; Command : ServerCommandName }
let generateServerCommandName (command : ServerCommand) =
    match command.Command with 
    | Capability (res, options) ->
        let lRes, rRes = res |> getOkBad
        [|(Untagged, [||], "CAPABILITY", options); (command.Tag, [|lRes|], "CAPABILITY", [|rRes|])|]
    | Noop res ->
        let lRes, rRes = res |> getOkBad
        [|command.Tag, [|lRes|], "NOOP", [|rRes|]|]
    | Logout res ->
        let lRes, rRes = res |> getOkBad
        [|(Untagged, [||], "BYE", [|"IMAP4rev1 Server logging out"|]); command.Tag, [|lRes|], "LOGOUT", [|rRes|]|]
let generateServerCommand (command : ServerCommand) = command |> generateServerCommandName |> Array.map (fun (t, l, n, r) -> generateLine t (l |> Array.map Some) n (r |> Array.map Some))

So now we have a manner of building commands, somewhat dynamically. We can construct a command from what it needs, which means we can continue on with the next step: authentication / authorization. That will be the subject of the next blog post, as I want to allow a lot of this to sink in, so that we can hit the ground running in the next situation. We have a whole hell-of-a-lot to do yet, so we'll take it in shorter, more manageable bits.

As a reminder, the code for this is on GitHub. The version for this specific blog post is tree 8d7b3f15777d0be7cd78903bb5f0c94d8175230d.

Due to time constraints, I didn't make it as far as I would have liked with this post. But never fear, consistent, slow progress is better than inconsistent progress.

Constructing an IMAP Server from Scratch - Part 1

2 March 2018 EBrown Blog (0)

Implementing Server-Side RFC 3501 (IMAP) in F# (Part 1)

So it's been a while, I've had little free time over the last couple months (December through February are my extrememly busy period), but I want to start a new project today, inspired by a complete failure of my existing mail provider to work properly.

Start with RTFM (or RFC's, in this case)

Now IMAP, as a protocol, is extraordinarily complicated. It is primarily detailed by RFC 3501, but many other RFC's have come in over the years to update it. As a result, we have 23 RFC's that relate to IMAP directly, and several more indirectly. I'm going to list the most important ones (in numeric order) first, then the extraneious ones.

Primarily, we have 18 RFC's to work with: 1730, 2060, 2061, 2088, 2342, 3501, 3502, 3516, 4466, 4469, 4551, 5032, 5182, 5738, 6237, 6855, 7162, and 7377.

We also have 5 additional RFC's for MIME that are extremely important: 2045. 2046, 2047, 2048, and 2049.

Additionally, there are 7 other RFC's that are directly relevant, though we can ignore for now: 2595, 5068, 5550, 6186, 6858, 7817, and 8314.

Finally, we have 6 other RFC's we'll need to think about: 2822, 5322, 5335, 5336, 6531, and 6854.

I don't expect you to read all of these, but you should know where to find them. We'll actually deal with most of the 36 RFC's detailed here tangentially, and I won't go into much detail on what parts of which RFC's we've implemented. (Though I haven't decided on that, yet.) The RFC rabbit-hole on IMAP is deep, and as a result we will need to be aware of issues we might run into that aren't detailed here. (We may discover new RFC's pertaining to what we're doing, for example.)

What is IMAP?

So let's back our complicated story up a little bit. First, let's talk about what is and isn't IMAP.

IMAP is the Internet Message Access Protocol, a protocol designed to allow a client (such as Outlook, Thunderbird, etc.) to retreive and update Internet Messages (Email's) associated with an account. This means you specify the account and credentials, the client uses those to perform IMAP interactions, and then displays those results to you.

This protocol does not specify how or where those messages must be stored (server or client side), nor how one can send messages to another Email box (which is typically SMTP / relays), it only specifies how a client system should access, modify, and remove Emails that it owns.

The short and simple: this means we can build a generic IMAP access protocol, which can then be used to interact with another service (or .NET library) for storage of the physical message.

Getting Started: Understanding Requirements

We'll begin our adventure down this IMAP server path by reading some of the RFC information. Fortunately, we won't read all of it, but we do have quite a bit of information to digest.

One of the more basic requirements we'll want to facilitate with our design is the transport-layer protocol and port, which happens to be TCP Port 143. This is found in RFC 3501 §2.1.

Another interesting note is the definition of a command / line, in RFC 3501 §2.2. By definition, a line ends in CRLF, and data is either a line, or a known length of octets (8-bit bytes) followed by a line.

Further in this same section, we are told that transferring data from Server to Client can happen on request, or be initiated by the server. We also learn that a client should generate an alpha-numeric "tag" which indicates which command the server is responding to. (There is no fixed syntax for a tag, just that it may only be alpha-numeric.)

Further reading tells us that there are a couple other items and states we'll need to keep. Particularly:

For each mailbox we must have a UIDVALIDITY value that is unique to that mailbox;
For each message, we must have a UID value that is unique to that message;

The combination of the mailbox name, UIDVALIDITY, and UID must describe a single message in the mail server. Each of these values is a 32-bit integer.

While there are many, many more requirements, I have set a goal to write code in every blog-post in this new series. As a result, I want to dive into writing, at the very least, a single-threading server for clients to connect to.

There are many examples out there of doing Open → Send → Receive → Close, but that's not what we want. With IMAP, we need to do an Open → Loop (Send → Receive) → Close. This obviously complicates things, especially once we get into mutliple concurrent connections.

So, to start this, we're going to build a demo client/server to get our infrastructure together. We're going to build one that allows us to send messages to the server, and pipe other messages back to the client. (Similar to a chat, but without message sharing.) This will allow us to build and demonstrate all the pieces of the IMAP infrastructure. (Many concurrent, connected clients, etc.) We're going to use F# Async-Computations to do so, which are actually really fun.

Let's start building a server!

Raw TCP/IP is a very difficult task to set out to implement without an understanding of how TCP/IP works. I'm not going to go into any of that detail, as I want to get right into writing some code, but the basics are that a TCP/IP connection is a "Socket", the socket is opened, and remains open until closed by the client or server. TCP/IP sockets are also bidirectional, meaning that at any given point the client and the server both reserve the right to unilaterally send data or close the connection.

We'll start with the TCP Server. This is an easy enough build, and can be abstracted to a pretty simple API. But before we do that, I want to make a few extensions to .NET.

Boilerplate

One of the pain-points (for me) with .NET is that there is no way to read an entire response from a raw TCP socket. For some reason (probably a good one), the designers left that part out. As a result, I always write some modifications to System.Net.Sockets.NetworkStream and System.Net.Sockets.Socket to make them more friendly:

module EBrown.Tcp.NetworkStream
open System.Net.Sockets

/// Add definitions to the `System.Net.Sockets.NetworkStream`
type NetworkStream with
    member stream.AsyncReceive (buffer : byte array, ?offset, ?count) =
        Async.FromBeginEnd(
            buffer, 
            defaultArg offset 0, 
            defaultArg count buffer.Length, 
            stream.BeginRead, 
            stream.EndRead)
    member stream.AsyncReceiveAll () =
        let rec receive buffer =
            async {
                let tempBuffer = 1024 |> Array.zeroCreate
                let! bytesReceived = tempBuffer |> stream.AsyncReceive
                let buffer = [|buffer; tempBuffer.[0..bytesReceived - 1]|] |> Array.concat
                if bytesReceived < tempBuffer.Length then return buffer else return! buffer |> receive }
        [||] |> receive
    member stream.ReadAll () =
        let rec receive buffer =
            let tempBuffer = 1024 |> Array.zeroCreate
            let bytes = (tempBuffer, 0, tempBuffer.Length) |> stream.Read
            let buffer = [|buffer; tempBuffer.[0..bytes - 1]|] |> Array.concat
            if bytes < tempBuffer.Length then buffer else buffer |> receive
        [||] |> receive
    member stream.Write (buffer : byte array) = stream.Write(buffer, 0, buffer.Length)

The first thing you see is AsyncRead, which performs an asynchronous call to BeginRead and EndRead, to do the entire thing in one go. This seems to be the most preferred way of doing .NET async operations at this level. The next line starts some interesting syntax: we define an AsyncReadAll function which will do an AsyncRead call until it has no more data. You might not have seen async { ... } before, or let! or return!, but they're F# Asynchronous Computation Expressions. I won't go into detail (because I don't really understand how they work, just how to use them) but we'll use them all over the place here.

The basics you need to know are that in an async block, you can make calls to other async code, and bind that. The let! (let bang) keyword will call to an async function, and bind the result, ONCE the result is ready. If the result isn't ready, then this function execution is paused and the thread is used elsewhere. The return! (return bang) will return the result of the async expression, after it's ready.

This is important to know because the following two lines are not the same:

let bytesReceived = tempBuffer |> stream.AsyncReceive
let! bytesReceived = tempBuffer |> stream.AsyncReceive

The first line binds an Async<int> to bytesReceived, whereas the second binds an int to bytesReceived. The first value is just a function call, that has not yet been started. The second calls the function and then yields the thread until the result is ready.

You then see that the NetworkStream has a ReadAll, which does a Read until no more data, and a Write, which does a stream.Write with a buffer.

Next we want to extend Socket to make life easier:

module EBrown.Tcp.Socket
open System.Net.Sockets

/// Add definitions to the `System.Net.Sockets.Socket`
type Socket with
    member socket.AsyncAccept () = Async.FromBeginEnd(socket.BeginAccept, socket.EndAccept)
    member socket.AsyncReceive (buffer : byte array, ?offset, ?count) =
        Async.FromBeginEnd(
            buffer, 
            defaultArg offset 0, 
            defaultArg count buffer.Length, 
            (fun (buffer, offset, size, callback, state) -> socket.BeginReceive(buffer, offset, size, SocketFlags.None, callback, state)), 
            socket.EndReceive)
    member socket.AsyncSend (buffer : byte array, ?offset, ?count) =
        Async.FromBeginEnd(
            buffer,
            defaultArg offset 0,
            defaultArg count buffer.Length,
            (fun (buffer, offset, size, callback, state) -> socket.BeginSend(buffer, offset, size, SocketFlags.None, callback, state)),
            socket.EndSend)
    member socket.AsyncReceiveAll () =
        let rec receive buffer =
            async {
                let tempBuffer = 1024 |> Array.zeroCreate
                let! bytesReceived = tempBuffer |> socket.AsyncReceive
                let buffer = [|buffer; tempBuffer.[0..bytesReceived - 1]|] |> Array.concat
                if bytesReceived < tempBuffer.Length then return buffer else return! buffer |> receive }
        [||] |> receive

This is the same as the NetworkStream for the most part, so I won't explain it.

Build a TCP Server

We're going to build two servers here, we'll build a TCP/IP server, and then an IMAP server. We'll do this because the raw TCP/IP server is pretty simple, and can be used for other servers as well.

A TCP/IP server needs two data-points to bind to: an IP Address, and a Port. These two values, when concatenated with a colon (:) make up a "socket". The server has a socket, and the client has a socket.

So one of the first things we need is the server endpoint: let endpoint = (ipAddress, port) |> IPEndPoint

So that's easy. The next thing we need is a server. In .NET we can accomplish a low-level TCP/IP server by using the Socket class (which we extended above), and binding. To start, we define our Socket:

let server = new Socket (AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp)

This builds a TCP/IP socket (which we named the server) to the InterNetwork address family (IP), the Stream socket type (raw bytes to and from), and the Tcp protocol (the TCP part of TCP/IP). Thus, we can use a stream to send and receive data.

Next, we bind:

(ipAddress, port) |> IPEndPoint |> server.Bind

Because I'm lazy, I bound and created the endpoint in the same line. This tells the server that it will be dealing specifically on the IP Address and Port we provided.

After binding, we listen:

SocketOptionName.MaxConnections |> int |> server.Listen

This builds a server with the MaxConnections configuration (allowing the maximum number of connections in the backlog) and then starts listening on the socket we asked for.

Once we've done that, we need to do the hard part. We need to do something with inbound connections, because by default the server doesn't actually do anything.

Listening for a new connection can be done with the socket.AsyncAccept function we built earlier, and because it's async we can ignore the threading issues (for the most part) and bind directly to it:

let! socket = () |> server.AsyncAccept

Now we won't get anything into socket until someone tries to connect, so we can then start working with that connection:

try Async.Start(socket |> events.Connect, cancellationToken = cts.Token)
with e -> ()

Now, what I did here is attempt to spawn a new asynchronous computation expression to handle the connection, it's not the job of the TCP/IP server to track that. We also passed a cancellation token in case we want to stop that expression later.

We'll then wrap that in an async { } block, and bind it to a function. If we include some basic logging, we have:

let cts = new CancellationTokenSource ()
let server = new Socket (AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp)
(ipAddress, port) |> IPEndPoint |> server.Bind
SocketOptionName.MaxConnections |> int |> server.Listen
(() |> ipAddress.ToString, port) ||> printfn "Started listening on %s:%d"

let rec waitForConnection () = 
    async {
        printfn "Waiting for connection..."
        let! socket = () |> server.AsyncAccept
        () |> socket.RemoteEndPoint.ToString |> printfn "Socket connected: %s"
        try Async.Start(socket |> events.Connect, cancellationToken = cts.Token)
        with e -> e.ToString() |> printfn "An error occurred: %s"
        return! () |> waitForConnection }

Good good, progress. Next, we want to unconditionally start the waitForConnection loop:

Async.Start(() |> waitForConnection, cancellationToken = cts.Token)

And finally, we'll build an IDisposable to properly handle closing the server:

{ new IDisposable with
    member this.Dispose () =
        () |> events.Close
        () |> cts.Cancel
        () |> server.Close
        () |> cts.Dispose
        () |> server.Dispose }

One of the things not defined here is events. I built a custom record for events the server can perform, which is extremely simple:

type ServerEvents =
    { Connect : Socket -> Async<unit>
      Close : unit -> unit }

Basically, we have a Connect and Close event.

All-in-all, if we put everything together and build a couple functions in a type, we have:

type Server () =
    static member StartI events port (ipAddress : IPAddress) =
        let cts = new CancellationTokenSource ()
        let server = new Socket (AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp)
        (ipAddress, port) |> IPEndPoint |> server.Bind
        SocketOptionName.MaxConnections |> int |> server.Listen
        (() |> ipAddress.ToString, port) ||> printfn "Started listening on %s:%d"

        let rec waitForConnection () = 
            async {
                printfn "Waiting for connection..."
                let! socket = () |> server.AsyncAccept
                () |> socket.RemoteEndPoint.ToString |> printfn "Socket connected: %s"
                try Async.Start(socket |> events.Connect, cancellationToken = cts.Token)
                with e -> e.ToString() |> printfn "An error occurred: %s"
                return! () |> waitForConnection }
        Async.Start(() |> waitForConnection, cancellationToken = cts.Token)

        { new IDisposable with
            member this.Dispose () =
                () |> events.Close
                () |> cts.Cancel
                () |> server.Close
                () |> cts.Dispose
                () |> server.Dispose }
    static member Start events port = (events, port, IPAddress.Any) |||> Server.StartI

Which is a fully-functional TCP/IP server that does nothing, as of yet.

Building the basic IMAP Server

Our basic IMAP server won't comply with any parts of the protocol, but it will function as an end-to-end test of TCP/IP and the server we created. The IMAP server will use a TCP/IP server instance from the previous class to handle the raw TCP/IP portions, then will use a mutable list of connected sockets (including a basic User ID) to manage the connections. It will also send a BYE on close of the server to all connected sockets, thus allowing us to tell clients we're not there anymore, cleanly.

To start this process, we'll actually define the Start function of the server:

member this.Start () = EBrown.Tcp.Server.Start { Connect = this.OnConnect; Close = this.OnClose } 143

This helps push us to the right direction of where to go next. We need to define OnConnect and OnClose, which will be called by the TCP/IP server.

The OnConnect function really only has one job: accept a connected client, spawn the async computation for it, and add it to the list of all sockets. So for that, we'll define a pretty brief function:

member this.OnConnect (socket : Socket) =
    async {
        try
            lock sockets (fun () -> sockets <- (socket, None)::sockets)
            sockets |> List.length |> printfn "Sockets open: %i"
            return! socket |> runClient
        finally
            lock sockets (fun () -> sockets <- sockets |> List.filter (fst >> (<>) socket))
            SocketShutdown.Both |> socket.Shutdown |> socket.Close
            sockets |> List.length |> printfn "Sockets open: %i" }

This function just takes a socket, indicates that it's open, and then runs the async computation for it. When it closes, it removes the socket from the open pool. Pretty simple and basic. What we see here, that we haven't yet written, is runClient.

The runClient function is a little more complex, as it will actually do some things in our IMAP server. For now, all we want it to do is echo back what the user sent over the socket, when the user sends data. For this, we'll use AsyncReceiveAll, and send back with AsyncSend:

let rec runClient (socket : Socket) =
    let printfn = printfn "Socket %s: %s" (socket.RemoteEndPoint.ToString())
    async {
        let! buffer = () |> socket.AsyncReceiveAll
        let str = buffer |> Encoding.ASCII.GetString
        sprintf "Received (%i bytes): %s" buffer.Length str |> printfn
        if str.Length = 3 && str = "BYE" then printfn "Disconnected"
        else
            let! bytesSent = [| "Hello, other world!"B |] |> Array.concat |> socket.AsyncSend
            bytesSent |> sprintf "Sent response (%i bytes)" |> printfn
            return! socket |> runClient }

The goal here, is to loop until we have to kill the socket (for any reason). Currently, the only valid reason is a BYE, but there may be others at some point. (Such as errors, authentication failures, etc.)

Finally, we need the OnClose function, which should kill the server and tell all clients it's gone. This is actually really simple:

member this.OnClose () =
    lock sockets (fun () ->
        sockets
        |> List.toArray
        |> Array.filter (fun (sock, _) -> sock.Connected)
        |> Array.map (fun (sock, user) -> [| "BYE"B |] |> Array.concat |> sock.AsyncSend)
        |> Async.Parallel
        |> Async.RunSynchronously
        |> ignore)

If we put it all together, and add our mutable sockets, we get:

type User = { Id : string }

type Server () =
    let mutable sockets : (Socket * User option) list = []
    let rec runClient (socket : Socket) =
        let printfn = printfn "Socket %s: %s" (socket.RemoteEndPoint.ToString())
        async {
            let! buffer = () |> socket.AsyncReceiveAll
            let str = buffer |> Encoding.ASCII.GetString
            sprintf "Received (%i bytes): %s" buffer.Length str |> printfn
            if str.Length = 3 && str = "BYE" then printfn "Disconnected"
            else
                let! bytesSent = [| "Hello, other world!"B |] |> Array.concat |> socket.AsyncSend
                bytesSent |> sprintf "Sent response (%i bytes)" |> printfn
                return! socket |> runClient }
    member this.OnConnect (socket : Socket) =
        async {
            try
                lock sockets (fun () -> sockets <- (socket, None)::sockets)
                sockets |> List.length |> printfn "Sockets open: %i"
                return! socket |> runClient
            finally
                lock sockets (fun () -> sockets <- sockets |> List.filter (fst >> (<>) socket))
                SocketShutdown.Both |> socket.Shutdown |> socket.Close
                sockets |> List.length |> printfn "Sockets open: %i" }
    member this.OnClose () =
        lock sockets (fun () ->
            sockets
            |> List.toArray
            |> Array.filter (fun (sock, _) -> sock.Connected)
            |> Array.map (fun (sock, user) -> [| "BYE"B |] |> Array.concat |> sock.AsyncSend)
            |> Async.Parallel
            |> Async.RunSynchronously
            |> ignore)
    member this.Start () = EBrown.Tcp.Server.Start { Connect = this.OnConnect; Close = this.OnClose } 143

So now we want to test it.

Testing our Server

To test our server we need to start it, and build a client to connect to it. Both are trivial:

use server = Server().Start()
Console.ReadLine() |> ignore
printfn "Closing..."

This runs the server, forever. It will stay online until the user presses "Enter".

The client is much simpler than the server, and is just a few lines of code:

printfn "Press [Enter] / [Return] to quit, any other character to send data."
let cts = new CancellationTokenSource ()
use client = new TcpClient("127.0.0.1", 143)
printfn "Connected to %s" (client.Client.RemoteEndPoint.ToString())
use stream = client.GetStream()

let sendData = 
    async {
        while (Console.ReadKey().Key <> ConsoleKey.Enter) do
            if not cts.IsCancellationRequested then
                printfn ""
                [| "Hello world!"B |] |> Array.concat |> stream.Write
        [| "BYE"B |] |> Array.concat |> stream.Write
        printfn "Disconnected" }
let receiveData = 
    async {
        let rec loop () =
            async {
                let! bytes = () |> stream.AsyncReadAll
                let str = bytes |> Encoding.ASCII.GetString
                printfn "Received %i bytes: %s" bytes.Length str
                if str.Length = 3 && str = "BYE" then printfn "Disconnected, press any key to exit."; cts.Cancel() else return! () |> loop }
        return! () |> loop }
Async.Start(receiveData, cancellationToken = cts.Token)
try Async.RunSynchronously(sendData, cancellationToken = cts.Token)
with | :? OperationCanceledException -> () | e -> printfn "%s" (e.ToString()); printfn "Press enter to exit..."; Console.ReadLine() |> ignore

We're not going to do client-side work at all, so I won't detail anything about it, but it's really quite trivial.

If we build out two console applications, throw this code in and make it work, we can test it and see the result:

Client:

Press [Enter] / [Return] to quit, any other character to send data.
Connected to 127.0.0.1:143
a
Received 19 bytes: Hello, other world!
Disconnected

Server:

Started listening on 0.0.0.0:143
Waiting for connection...
Socket connected: 127.0.0.1:57309
Waiting for connection...
Sockets open: 1
Socket 127.0.0.1:57309: Received (12 bytes): Hello world!
Socket 127.0.0.1:57309: Sent response (19 bytes)
Socket 127.0.0.1:57309: Received (3 bytes): BYE
Socket 127.0.0.1:57309: Disconnected
Sockets open: 0

And there we have it. We've built bi-directional TCP/IP in a small amount of F# code, and can now begin the adventure of building the actual IMAP server.

If you are lazy, like me, and want this project for free, the entire thing will be available on GitHub. The version for this specific blog post is tree 8d269692ab169806e87b59700d69853b1d2eb1ff.

The blog post today is brought to you buy a significant amount of Coca-Cola and Fritos. I do not recommend either of these products unless you hate yourself (like me) and are trying to gain a lot of unnecessary weight. What I do recommend, however, is that you try to enjoy yourself as much as possible, and ignore what anyone else says about that. (You do you, basically.)

It's been a short while, as I took a longer-than-expected hiatus after the F# Advent of Code, but I'm back and we're going to work on a fun little project that involves a lot of detail and such.

Building a Rashberry Pi Graphing Machine

17 January 2018 EBrown Blog (0)

Building the software for a Rasberry Pi Weather Instrument System

Per the usual I recently tweeted about a thing, which was a Raspberry Pi Weather Measurement System, in particular I tweeted a picture of the graphs (and asked an expert in statistics / data-science for an assist on how to best model the data), and said expert actually responded with some helpful information.

Of course, shortly afterward someone asked me how to create said thing, so that's what this blog-post is about: how did I create the graphing system there?

Now, because you might not have a Raspberry Pi of your own to play with, I'm going to demonstrate with a blank Debian install (because my Raspberry Pi OS is Rasbian), and we'll go through the whole thing pretty quick as far as setup.

For me, I use Oracle (is it Oracle now? It was Sun when I started using it) VirtualBox, which is a freaking awesome piece of software. I then setup a Debian VM, get Debian installed with a minimal graphical config (XFCE), and then we can get started.

Step 1: Install MariaDB and Apache with Python

The first step to getting our setup going is to install MariaDB / MySQL. For this, a simple command is necessary (if using Debian 9.3 you'll want to su - then use the command instead of sudo with the command, as it seems like sudo isn't always included by default):

sudo apt-get install mariadb-server

(If it gives you crap about inserting a CD ROM, you can sudo nano /etc/apt/sources.list, then put a # as the first character on the first line without it, then CTRL + O, press [Return], then CTRL + X.) My MariaDB did not prompt for a password (it installed with a root user with no password), but if yours prompts you for a password just pick something you can remember (we'll need it later).

Next, we want to install Apache / httpd, and set it up for Python hosting. This is, once again, a pretty simple command:

sudo apt-get install apache2

Then set it up for Python, I won't detail the commands but they're pretty simple:

sudo a2dismod mpm_event
sudo a2enmod mpm_prefork cgi

Modify the /etc/apache2/sites-enabled/000-default.conf:

sudo nano /etc/apache2/sites-enabled/000-default.conf

In that config file, you want to add an Options line with +ExecCGI as the argument inside the Directory, which you should create if it doesn't exist (added mine right after the <VirtualHost *:80> line. You also want to set the index.

<Directory /var/www/html>
    Options + ExecCGI
    DirectoryIndex index.py
</Directory>

Next we want to AddHandler cgi-script .py after the directory lines:

AddHandler cgi-script .py

Finally:

sudo service apache2 restart

Step 2: Create a database

Assuming you setup MySQL / MariaDB, you should be able to login:

mysql -u ... -p

Where ... is your username (probably root, I'm insecure). If you don't have a password set, omit the -p bit. We create a database:

CREATE DATABASE WhateverNameYouReallyLike;
USE WhateverNameYouReallyLike;

Then we'll create a table (you can make as many as you need, I always make one per sensor):

CREATE TABLE TemperatureLog
(
    Logged datetime NOT NULL,
    Sample int(2) NOT NULL,
    Value float(11, 3) NOT NULL,
    PRIMARY KEY (Logged, Sample)
);

You can make as many as you need, I have 6, because I have that many sensor values.

Finally, make a user:

CREATE USER 'SomeUsername' IDENTIFIED BY 'SomePassword';
GRANT ALL ON WhateverNameYouReallyLike.* TO 'SomeUsername';

Step 3: Log to the Database

This part I won't detail much, we'll build a sample cron job that adds random data, not ideal but it'll get our graphing to work like we want.

We won't use truly random data, we'll actually use a formula with a little bit of a random skew, so that we see the graph adjust slightly but also to allow us to see how our tick settings and such work.

First we'll install pymysql, which isn't available by default:

sudo apt-get install python-pymysql

Then, create a test.py or something, with the following contents:

#!/usr/bin/python
from datetime import datetime
from time import sleep
from random import randint

import sys
import pymysql

SAMPLES = 5
DELAY = 2
DATE_FORMAT = "%Y-%m-%d %H:%M:%S"

def build_query(table, date, sample, value):
    template = """INSERT INTO {table} (Logged, Sample, Value) VALUES ('{logged}', {sample}. {value})"""
    return template.format(table=table, logged=date, sample=sample, value=value)

if __name__ == '__main__':
    date_val = datetime.utcnow()
    date = date_val.strftime(DATE_FORMAT)
    conn = pymysql.connect (
        db='WhateverNameYouLike',
        user='SomeUsername',
        passwd='SomePassword',
        host='localhost')
    cursor = conn.cursor()

    for sample in range(SAMPLES):
        value = date_val.hour * 60 + date_val.minute
        value = abs(1800 - value) / 100.0
        temp = value + (randint(0, 9) / 100.0)
        cursor.execute(build_query("TemperatureLog", date, sample, temp))
        print "Temp: {0}".format(temp)
    conn.commit()

Now the values themselves don't really matter, but they should range from 0 to 18, then back down. (0 at noon, 18 at midnight), that way we see a nice curve.

Next step is to setup a cronjob, usually cron is installed by default but if it's not there are articles on the internet about it.

We'll make a /etc/cron.d/test for ours, and fill it with:

SHELL=/bin/sh
* * * * * pi /home/pi/test.py

Chances are you are on a Raspberry Pi, so pi will be after the five asterisks, then /home/py/test.py is the path to your python file.

This will run every minute, so we'll let it run while we work on the next bit.

Step 4: Setup graphing (this is the fun part)

We want to get our Apache server setup to host some python, HTML and Javascript which allows us to view live-graphs.

We'll test Apache quick with an index.py:

#!/usr/bin/python
print "Content-Type: text/html"
print ""
print "Test"

If well-and-good you should see "Test" printed to your screen.

Now things get fun.

For graphing, I always use [d3.js], which is a really powerful and robust bit of JavaScript, it does a lot of stuff, far more than I know, so I just trust it for the most part (probably bad but oh well). You'll want to download the .zip, and pull all the files into a d3 folder in your /var/www/html.

You also probably want jQuery, I'm using 1.12.4 min, and whatever design stuff you want (bootstrap, etc.).

We want to make our index.py pretty simple:

#!/usr/bin/python
# Header must always be printed first
print "Content-type: text/html"
print ""

if __name__ == "__main__":
    with open("index.html") as template:
        print template.read()

That's it, we'll use index.html to hold all our stuff. (Realistically, we could have left the document root of Apache as index.html and just used it, but I had it setup this way because I did a couple weird things in the index.py.) The nice thing here is this still proves your python works.

Next, we want to define a time.py, which will be a sort of API:

#!/usr/bin/python
from datetime import datetime, timedelta
import cgi

DEFAULT_DATE_FORMAT = "%Y-%m-%d %H:%M:%S"

# Header must always be printed first
print "Content-type: text/html"
print ""

if __name__ == "__main__":
    args = cgi.FieldStorage()
    date_format = DEFAULT_DATE_FORMAT
    if "DateFormat" in args:
        date_format = args["DateFormat"].value

    if "Next" in args or "All" in args:
        utctime = datetime.utcnow()
        print (utctime + timedelta(seconds = 60 - utctime.second)).strftime(date_format)
   if "NextIn" in args or "All" in args:
        utctime = datetime.utcnow()
        print str(60 - utctime.second) + " seconds"
    if (not "Next" in args and not "NextIn" in args) or "All" in args:
        print datetime.utcnow().strftime(date_format)

Alright, so we're going to use this to display the system time and the countdown to the next thing. You can test it directly, it should print your current system time (in UTC).

Next I'll give you my stylesheet, it's pretty basic:

body { 
    background: #202020;
    color: #efefef;
    width: 100%;
    height: 100%;
    overflow: hidden;
}
html { height: 100%; }

.graphBlock {
    max-height: 100%:
    max-width: 100%;
    height: 100%;
    width: 100%;
    text-align: center;
}

svg { display: inline-block; }
.graphBlock svg { width: 100%; }
.graphBlock.split svg { width: 49%; }
.right { float: right; }
.axis line { stroke: #303030; }
.axis.y path, .axis.y .tick:nth-child(2) line { stroke: #efefef; }
.axis path { stroke: #303030; }
svg text { fill: #efefef; }

.header, .current {
    background: #07507F;
    padding: 5px;
}

.current { border-bottom: 1px solid #30303; }
select, input { color: #202020; }

Alright, so the stylesheet is done. Things only gett more interesting from here. We have a graph.js file to define:

function buildGraph(svgTitle, table, title, unit, params, cb) {
    var svg = d3.select(svgTitle);
    var margin = {top: 20, right: 20, bottom: 30, left: 40};
    var vb = svg.attr("viewBox").split(" ");
    var width = +vb[2] - margin.left - margin.right;
    var height = +vb[3] - margin.top - margin.bottom;
    var g = svg
        .append("g")
        .attr("transform", "translate(" + margin.left + "," + margin.top + ")")
        .attr("width", width);

    var parseTime = d3.timeParse("%Y-%m-%d %H:%M:%S");

    var x = d3.scaleTime().rangeRound([0, width]);
    var y = d3.scaleLinear().rangeRound([height, 0]);

    var line = d3.line()
        .curve(d3.curveMonotoneX)
        .x(function(d) { return x(d.Logged); })
        .y(function(d) { return y(d.Value); });

    var area = d3.area()
        .curve(d3.curveMonotoneX)
        .x(function(d) { return x(d.Logged); })
        .y1(function(d) { return y(d.Value); });

    d3.tsv("history.py?LogType=" + table + "&" + params, function(d) {
        d.Logged = parseTime(d.Logged);
        d.Value = +d.Value;
        return d;
    }, function(error, data) {
        if (error) throw error;

        x.domain(d3.extent(data, function(d) { return d.Logged; }));
        var yS = y.domain(d3.extent(data, function(d) { return d.Value; })).nice();

        area.y0(y(yS.domain()[0]));

        g.append("g")
            .attr("class", "x axis")
            .attr("transform", "translate(0," + height + ")")
            .call(d3.axisBottom(x).tickSize(-height))
            .select(".domain");

        g.append("g")
            .attr("class", "y axis")
            .call(d3.axisLeft(y).tickSize(-width))
            .append("text")
            .attr("fill", "#000")
            .attr("transform", "rotate(-90)")
            .attr("y", 6)
            .attr("x", -4)
            .attr("dy", "0.71em")
            .attr("text-anchor", "em")
            .text(title);

        g.select(".y")
            .select(".domain")
            .attr("transform", "translate(-1,0)");

        g.append("path")
            .datum(data)
            .attr("fill", "none")
            .attr("stroke", "steelblue")
            .attr("stroke-linejoin", "round")
            .attr("stroke-linecap", "round")
            .attr("stroke-width", 1.5)
            .attr("d", line);

        g.append("path")
            .datum(data)
            .attr("fill", "steelblue")
            .attr("fill-opacity", "0.25")
            .attr("stroke", "none")
            .attr("d", area);

        g.append("text")
            .attr("fill", "#000")
            .attr("y", "4")
            .attr("x", width - 4)
            .attr("dy", "0.71em")
            .attr("font-size", "11")
            .attr("text-anchor", "end")
            .text(parseFloat(Math.round(data[data.length - 1].Value * 100) / 100).toFixed(2) + unit);
        cb();
    });
}

function updateGraph(svgTitle, table, title, unit, params, cb) {
    var svg = d3.select(svgTitle);
    var margin = {top: 20, right: 20, bottom: 30, left: 40};
    var vb = svg.attr("viewBox").split(" ");
    var width = +vb[2] - margin.left - margin.right;
    var height = +vb[3] - margin.top - margin.bottom;
    var g = svg.select("g");

    var parseTime = d3.timeParse("%Y-%m-%d %H:%M:%S");

    var x = d3.scaleTime().rangeRound([0, width]);
    var y = d3.scaleLinear().rangeRound([height, 0]);

    var line = d3.line()
        .curve(d3.curveMonotoneX)
        .x(function(d) { return x(d.Logged); })
        .y(function(d) { return y(d.Value); });

    var area = d3.area()
        .curve(d3.curveMonotoneX)
        .x(function(d) { return x(d.Logged); })
        .y1(function(d) { return y(d.Value); });

    d3.tsv("history.py?LogType=" + table + "&" + params, function(d) {
        d.Logged = parseTime(d.Logged);
        d.Value = +d.Value;
        return d;
    }, function(error, data) {
        if (error) throw error;

        x.domain(d3.extent(data, function(d) { return d.Logged; }));
        var yS = y.domain(d3.extent(data, function(d) { return d.Value; })).nice();

        area.y0(y(yS.domain()[0]));

        g.selectAll("path").remove();
        g.selectAll("g").remove();
        g.selectAll("text").remove();

        g.append("g")
            .attr("class", "x axis")
            .attr("transform", "translate(0," + height + ")")
            .call(d3.axisBottom(x).tickSize(-height))
            .select(".domain");

        g.append("g")
            .attr("class", "y axis")
            .call(d3.axisLeft(y).tickSize(-width))
            .append("text")
            .attr("fill", "#000")
            .attr("transform", "rotate(-90)")
            .attr("y", 6)
            .attr("x", -4)
            .attr("dy", "0.71em")
            .attr("text-anchor", "em")
            .text(title);

        g.select(".y")
            .select(".domain")
            .attr("transform", "translate(-1,0)");

        g.append("path")
            .datum(data)
            .attr("fill", "none")
            .attr("stroke", "steelblue")
            .attr("stroke-linejoin", "round")
            .attr("stroke-linecap", "round")
            .attr("stroke-width", 1.5)
            .attr("d", line);

        g.append("path")
            .datum(data)
            .attr("fill", "steelblue")
            .attr("fill-opacity", "0.25")
            .attr("stroke", "none")
            .attr("d", area);

        g.append("text")
            .attr("fill", "#000")
            .attr("y", "4")
            .attr("x", width - 4)
            .attr("dy", "0.71em")
            .attr("font-size", "11")
            .attr("text-anchor", "end")
            .text(parseFloat(Math.round(data[data.length - 1].Value * 100) / 100).toFixed(2) + unit);
        cb();
    });
}

This is the D3 bit, it basically build an individual graph from the provided parameters.

The last two python files are for the history (which was in the blue field in my screenshot) and for the latest, which gathers the data-points for D3:

#!/usr/bin/python
from datetime import datetime, timedelta

import cgi
import pymysql

DATE_FORMAT = "%Y-%m-%d %H:%M:%S"
DEFAULT_DAY_LIMIT = 7
DEFAULT_MINUTE_GROUPING = 3

if __name__ == '__main__':
    print "Content-type: text/html"
    print

    args = cgi.FieldStorage()
    day_limit = DEFAULT_DAY_LIMIT

    if "Days" in args:
        day_limit = float(args["Days"].value)

    start_date = (datetime.utcnow() - timedelta(days = day_limit)).strftime(DATE_FORMAT)
    end_date = datetime.utcnow().strftime(DATE_FORMAT)
    minute_group = DEFAULT_MINUTE_GROUPING

    if "MinuteGroup" in args:
        minute_group = float(args["MinuteGroup"].value)

    table = "TemperatureLog"

    formatter = lambda c: c * 1.8 + 32

    if "LogType" in args:
        log_type = args["LogType"].value
        if log_type == "Humidity":
            table = "HumidityLog"
            formatter = lambda x: x
        elif log_type == "BmpTemp":
            table = "BmpTempLog"
            formatter = lambda c: c * 1.8 + 32
        elif log_type == "Pressure":
            table = "PressureLog"
            formatter = lambda p: p * 0.0002953
        elif log_type == "Altitude":
            table = "AltitudeLog"
            formatter = lambda m: m * 3.28084
        elif log_type == "SeaPressure":
            table = "SeaPressureLog"
            formatter = lambda p: p * 0.0002953

    if "Start" in args:
        start_date = args["Start"].value
    if "End" in args:
        end_date = args["End"].value

    conn = pymysql.connect(
        db='WhateverNameYouReallyLike',
        user='SomeUsername',
        passwd='SomePassword',
        host='localhost')
    cursor = conn.cursor()

    cursor.execute("""
        SELECT
            Logged, AVG(Value)
        FROM
            {0}
        WHERE
            Logged >= '{1}' AND Logged <= '{2}'
        GROUP BY
            ROUND(UNIX_TIMESTAMP(Logged)/({3} * 60));""".format(table, start_date, end_date, minute_group))

    didfirst = 0
    print "Logged\tValue"
    for row in cursor.fetchall():
        didfirst = 1
        print "{0}\t{1}".format(row[0], formatter(row[1]))

We're going to call this file history.py. The last python file is latest.py:

#!/usr/bin/python
from datetime import datetime, timedelta

import cgi
import pymysql

DATE_FORMAT = "%Y-%m-%d %H:%M:%S"
DEFAULT_DAY_LIMIT = 7
DEFAULT_MINUTE_GROUPING = 1

if __name__ == '__main__':
    print "Content-type: text/html"
    print

    args = cgi.FieldStorage()
    start_date = (datetime.utcnow() - timedelta(days = DEFAULT_DAY_LIMIT)).strftime(DATE_FORMAT)
    end_date = datetime.utcnow().strftime(DATE_FORMAT)
    minute_group = DEFAULT_MINUTE_GROUPING
    gather = []

    gather.append(("TemperatureLog", lambda c: c * 1.8 + 32))

    if "Start" in args:
        start_date = args["Start"].value
    if "End" in args:
        end_date = args["End"].value

    conn = pymysql.connect(
        db='WhateverNameYouReallyLike',
        user='SomeUsername',
        passwd='SomePassword',
        host='localhost')
    cursor = conn.cursor()

    for table, formatter in gather:
        cursor.execute("""
            SELECT
                Logged, AVG(Value)
            FROM
                {0}
            WHERE
                Logged >= '{1}' AND Logged <= '{2}'
            GROUP BY
                ROUND(UNIX_TIMESTAMP(Logged)/({3} * 60))
            ORDER BY
                Logged DESC
            LIMIT
                1;""".format(table, start_date, end_date, minute_group))

        for row in cursor.fetchall():
            print "{2}\t{0}\t{1}".format(row[0], formatter(row[1]), table[:-3])

So now there's only one file left, which is our index.html. I guess let's lay it out:

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
        <link href="style.css" rel="stylesheet" />
        <script src='d3/d3.min.js'></script>
        <script src='graphs.js'></script>
</head>
<body>
    <div class="header">
        Last refresh: <span class="lastRefresh"></span>;
                    Pi time: <span class="piTime"></span>;
        Next sensor pull: <span class="nextRefresh"></span> (<span class="nextRefreshSeconds"></span>)
        <div class="right">
            Graph Timeline:
            <select id="days">
                <option value="0.041666667">1 hour</option>
                <option value="0.125">3 hours</option>
                <option value="0.25">6 hours</option>
                <option value="0.5">12 hours</option>
                <option value="1">1 day</option>
                <option value="2">2 days</option>
                <option value="3">3 days</option>
                <option value="4">4 days</option>
                <option value="5">5 days</option>
                <option value="6">6 days</option>
                <option value="7" selected>1 week</option>
                <option value="14">2 weeks</option>
                <option value="28">4 weeks</option>
                <option value="30">1 month</option>
                <option value="60">2 months</option>
                <option value="90">3 months</option>
            </select>
        </div>
    </div>
    <div class="current">
        Current readings (<span id="logValue"></span>):
        <span class="">
            Temp 1:
            <span id="temperatureValue"></span>F
        </span>
        <div class="right">
            Ticks:
            <select id="minuteGroup">
                <option value="0.083333">5 seconds</option>
                <option value="0.166667">10 seconds</option>
                <option value="0.25">15 seconds</option>
                <option value="0.5">30 seconds</option>
                <option value="1" selected>1 minute</option>
                <option value="2">2 minutes</option>
                <option value="3">3 minutes</option>
                <option value="5">5 minutes</option>
                <option value="10">10 minutes</option>
                <option value="15">15 minutes</option>
                <option value="30">30 minutes</option>
                <option value="60">1 hour</option>
                <option value="120">2 hours</option>
                <option value="180">3 hours</option>
                <option value="240">4 hours</option>
                <option value="360">6 hours</option>
                <option value="720">12 hours</option>
                <option value="1440">1 day</option>
            </select>
        </div>
        <br />
    </div>
    <div class='graphBlock split'>
        <svg class='temp' viewBox='0 0 1 1'></svg>
    </div>
    <script src='jquery.1.12.4.min.js'></script>

    <script>
        var loading = 0;

        Number.prototype.padLeft = function(base, chr) {
        var len = (String(base || 10).length - String(this).length) + 1;
            return len > 0 ? new Array(len).join(chr || '0') + this : this;
        }

        function round(value, decimals) {
            return Number(Math.round(value + 'e' + decimals) + 'e-' + decimals);
        }

        function graphDone() {
            loading -= 1;
        }

        function updateGraphs(callback) {
            if (loading > 0) { return; }

            clearInterval(graphInt);
            if (callback == null) {
                callback = updateGraph;
            }

            var days = "Days=" + $("#days").val() + "&MinuteGroup=" + $("#minuteGroup").val();
            loading = 1;

            var subHeight = $(".header").outerHeight() + $(".current").outerHeight();
            var vb = "0 0 ";

            if ($(".graphBlock").hasClass("split")) {
                vb += $(".graphBlock").outerWidth() / 2;
                vb += " ";
                vb += ($(".graphBlock").outerHeight() - subHeight) / 3;
            } else {
                vb += $(".graphBlock").outerWidth() / 1;
                vb += " ";
                vb += ($(".graphBlock").outerHeight() - subHeight) / 6;
            }

            $('svg').each(function () { $(this)[0].setAttribute('viewBox', vb); });
            callback('.temp', 'Temperature', 'Temp (F)', "ºF", days, graphDone);

            var d = new Date;
            var dFormat = [d.getUTCFullYear(), (d.getUTCMonth() + 1).padLeft(), d.getUTCDate().padLeft()].join('-');
            dFormat += " ";
            dFormat += [d.getUTCHours().padLeft(), d.getUTCMinutes().padLeft(), d.getUTCSeconds().padLeft()].join(':');
            $('.lastRefresh').html(dFormat);
            graphInt = setInterval(updateGraphs, 5000);
        }

        function updateTimes() {
            clearInterval(timeInt);
            var xmlHttp = new XMLHttpRequest();
            xmlHttp.onreadystatechange = function() {
                if (xmlHttp.readyState == 4 && xmlHttp.status == 200) {
                    var text = xmlHttp.responseText.trim().split("\n");
                    $(".nextRefresh").html(text[0]);
                    $(".nextRefreshSeconds").html(text[1]);
                    $(".piTime").html(text[2]);
                    timeInt = setInterval(updateTimes, 500);
                }
            }
            xmlHttp.open("GET", "time.py?All=true", true);
            xmlHttp.send(null);
        }

        function updateCurrents() {
            clearInterval(currentInt);
            var xmlHttp = new XMLHttpRequest();
            xmlHttp.onreadystatechange = function() {
                if (xmlHttp.readyState == 4 && xmlHttp.status == 200) {
                    var text = xmlHttp.responseText.trim().split("\n");
                    text.forEach(function(line) {
                        var items = line.split("\t");
                        switch (items[0]) {
                            case "Temperature":
                                $("#temperatureValue").html(round(items[2], 2));
                                break;
                        }
                        $("#logValue").html(items[1]);
                    });
                    currentInt = setInterval(updateCurrents, 1000);
                }
            }
            xmlHttp.open("GET", "latest.py", true);
            xmlHttp.send(null);
        }

        var graphInt = setInterval(updateGraphs, 5000);
        var timeInt = setInterval(updateTimes, 500);
        var currentInt = setInterval(updateCurrents, 1000);
        updateGraphs(buildGraph);
        updateTimes();
        updateCurrents();
    </script>
</body>
</html>

Yeah it's long, yeah it's ugly, but it works. :)

Alright, so if you put all this together you should have a graphing utility, that automatically refreshes (the setInterval lines do that, the 5000, 1000 and 500 are milliseconds), and the cron-job will keep data moving in.

The graphs update every 5 seconds or so, so you should be able to change the "Ticks" or "Graph Timeline" setting and see a very quick reaction. You will also see that all of this is setup for adding new tables (with the same structure) for new graphs / sensors.

F# Advent Day of Code: Modeling types to prevent bugs

20 December 2017 EBrown Blog (0)

F# Advent Day of Code: Taking advantage of the F# Type-System

Today is my date for F# Advent, and I want to discuss as pretty large topic, which happens to be domain modeling with F# types, and how to model the types to prevent bugs.

One of the "going jokes" in the F# community is that "if it compiles, it works and bug free." This is obviously not entirely true, there's always a possibility that it won't work properly, but it is actually proven fairly often. Part of this is because of F#'s type system, the strong-typing requisite, and the fact that it does not implicitly convert them. The problem, and often the source of bugs that do manifest, is that without a little thinking, it's hard to build a type-structure that creates this "bug free" scenario. It can be done, but you have to forget about how you think about types.

In this lesson we're going to take a library I'm preparing to open-source, and discuss how to build a type-system that is mostly flawless, and doesn't allow us to model incorrect structure or state.

Step 1: same as usual, identify the problem

The first step of any program is to identify the problem. In our situation, the problem I'm proposing to solve is the enormous problem of generating HTML code from a non-HTML language, and not writing it by hand. More often than not I'm forced to look up intricacies of HTML, and subtleties that really ought to be a lot easier. We're also going to see how we can generate HTML that is 100% conformant to the HTML specification, and how we can even embed compiler warnings into our system, such that if it compiles, it's valid HTML.

Remember that F# is a functional language, and uses an algebraic type-system. The language itself is designed to support these types of ideas natively and out of the box, so we're going to go over the basics of building this system, and we'll cover what the type-system gives us that enables compile-time safety of a generated system.

Step 2: solve the problem

This is the last heading, and it's going to be long, so buckle-up and enjoy the ride.

HTML is a language that is used predominantly to generate markup for websites and web-based applications. It's used to define a structure which a browser or device can use to render and organize content. A basic, perfectly valid, HTML page might look as follows:

A Page Title

To a normal developer like myself, there's nothing to this. We define the "DOCTYPE" first, then define the HTML content. This is a basic HTML5 compliant page, that only has a title and no content. HTML does not require content, but it does, interestingly, require the <title> element.

Now from this we can begin extracting some types. We can start to define how we want to model the type-system to make sure that we always generate a perfectly compliant page. We see that HTML has a few characteristics:

A DOCTYPE defining the document;
A <head> including the meta-data of the document;
A <title> in the head defining the title of the document;
A <body> including the content of the document;

With this, we'll actually build a quick type:

type DocType_V1 = | Html5
type Head_V1 = { Title : string }
type Document_V1 = { Doctype : DocType_V1; Head : Head_V1; Body : string }

let html5Document_v1 = { Document_V1.Doctype = Html5; Head = { Head_V1.Title = "A Test Document" }; Body = "" }

While this is a perfectly valid type, this doesn't solve our problem yet. All we have accomplished here is defining the "basics" of HTML, we can actually have a completely invalid <body> at this point. We also have none of the additional features available in the <head> element, such as <meta> tags, style-sheets, JavaScript, etc. Because I'm pragmatic, we're going to work from top-to-bottom, so we'll start with defining a better document.

The biggest issue here is that there are 7 major document types in modern HTML:

HTML 5 (the newest);
HTML 4.01 Frameset (very loose definition);
HTML 4.01 Transitional (less loose, but still not very strict);
HTML 4.01 Strict (very strict, compliant definition);
XHTML 1.0 Frameset (a loose XHTML definition);
XHTML 1.0 Transitional (less loose, but still not very strict XHTML definition);
XHTML 1.0 Strict (very strict, compliant XHTML definition);

Knowing this, there's actually very different aspects to each document type. Therefore, it doesn't make sense to use an enum for it, it instead makes sense to use a outer union for it:

type Head_V2 = { Title : string }
type StrictDocument_V2 = { Head : Head_V2; Body : string }
type TransitionalDocument_V2 = { Head : Head_V2; Body : string }
type FramesetDocument_V2 = { Head : Head_V2; Body : string }
type DocumentForm_V2 = | Strict of StrictDocument_V2 | Transitional of TransitionalDocument_V2 | Frameset of FramesetDocument_V2
type Document_V2 = | Html5Document of StrictDocument_V2 | Html4Document of DocumentForm_V2 | XhtmlDocument of DocumentForm_V2

let html5Document_v2 = Document_V2.Html5Document { StrictDocument_V2.Head = { Head_V2.Title = "A Test Document" }; Body = "" }

What just became quite interesting is that it's actually impossible to model an unsupported document type now. Previously, we would actually hit an issue where it would become possible to model a document that was not a StrictDocument, which would create an invalid HTML document.

The next step is to model some of the <meta> tags that are often placed inside a <head> element. These are things like the document character-set, linked-resources, language, description, keywords, etc. The <meta> tags can also be free-form, meaning they can be a tag to support things like Facebook descriptions and identifiers which help with creating pages that are more friendly to the social-network, etc. To support this we'll actually build mutliple meta-tag models.

To model this, we'll start with the "standard" meta-data's to be supported. This is easily modeled following the requirements in the HTML5 specification which is freely (and easily) accessible:

type StandardMeta_V3 = | ApplicationName of Lang : string option | Author | Description | Generator | Keywords | Referrer

The interesting tag here is ApplicationName, which allows you to specify between zero and one, inclusive, tags with the same "language". These would be included in the document as follows:

The kicker is that lang is optional, and there may be only one of each lang value in a document.

Another important aspect of a <head> element is the charset, or character-set. Every HTML page is allowed to declare a <meta> tag with a name="charset" attribute exactly once, and this charset should be the encoding used to send the page from server to browser. We'll actually define an enum type for this:

type Charset_V3 = | Utf8

And we'll include this and the standard <meta> tags in the new Head element:

type Head_V3 = { Title : string; Charset : Charset_V3 option; StandardMetas : Map<StandardMeta_V3, string> }

Still quite simple, and we'll use our previous model with a few minor modifications:

type StrictDocument_V3 = { Head : Head_V3; Body : string option }
type TransitionalDocument_V3 = { Head : Head_V3; Body : string option }
type FramesetDocument_V3 = { Head : Head_V3; Body : string option }
type DocumentForm_V3 = | Strict of StrictDocument_V3 | Transitional of TransitionalDocument_V3 | Frameset of FramesetDocument_V3
type Document_V3 = | Html5Document of StrictDocument_V3 | Html4Document of DocumentForm_V3 | XhtmlDocument of DocumentForm_V3

let html5Document_v3 =
    Document_V3.Html5Document
      { StrictDocument_V3.Head =
          { Head_V3.Title = "A Test Document"
            Charset = Some Charset_V3.Utf8
            StandardMetas = [(StandardMeta_V3.ApplicationName (Some "en"), "Test Application"); (StandardMeta_V3.Description, "A test application.")] |> Map.ofList }
        Body = None }

Side note: we used Map, but as there's currently no syntax to construct a map natively, it's possible to create a situation where the compiler will not stop us from creating an invalid list, this is something the F# team has on the list, and hopefully it's resolved sooner rather than later.

So now that we have a document created and modeled, it's time to generate. Fortunately, generating HTML is actually really easy if you follow the rules / guidelines. For XHTML that means always lower-case the attribute and tag names, for regular HTML it's not as strict, but still has rules.

The first rule of HTML and XHTML alike is the DOCTYPE, which is (fortunately) a static list. For us, we care about the following:

let getDoctype_v3 document =
    match document with
    | Document_V3.XhtmlDocument (Strict _) -> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
    | XhtmlDocument (Transitional _) -> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"
    | XhtmlDocument (Frameset _) -> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
    | Html4Document (Strict _) -> "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
    | Html4Document (Transitional _) -> "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">"
    | Html4Document (Frameset _) -> "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">"
    | Html5Document _ -> "<!DOCTYPE HTML>"

With this single function, we can get every DOCTYPE we need for all our supported models.

let html5Document_v3_doctype = html5Document_v3 |> getDoctype_v3

This ought to return <!DOCTYPE HTML>. You'll notice that for all three of the XHTML DOCTYPE results, html is lower-case. That's part of the spec I mentioned.

As usual, I want to declare a couple functions we'll use for the whole project:

let joinStrings sep (strs : string array) = System.String.Join(sep, strs)
let prependIfText sep str = if str |> Seq.isEmpty |> not then sprintf "%s%s" sep str else ""

They just make life easier.

Next, we need to think about our document. Our document is made up of "elements" which are represented as "tags", and tags have a couple rules about them:

Some tags are allowed to self-close, or <tag /> vs <tag></tag> (the <script> tag for example cannot self-close);
Some tags are "inline" tags, that is, we don't want to break lines inside the tag (like <title>, we want to do <title>...</title>, without a line-break);
Some tags have attributes, and some do not;
Some tags will have content, and some will not;
All tags have a name;

With this, we can begin to define a function that will fulfill these requirements. We'll always know ahead-of-time whether the tag will allow self-closing, and whether or not we want to include line-breaks, so we want to start defining an API:

let renderTag_v3_1 (selfClose : bool) (includeBreaks : bool) (tagName : string) = ()

Obviously we need to add a body to the function, but this starts us off. We can then define functions which will alias to this function. The next item should probably be attributes, because sometimes we'll have those and sometimes we won't.

We probably want to include content as well, so our final API might look like:

let renderTag_v3_2 (selfClose : bool) (includeBreaks : bool) (tagName : string) (attrs : Map<string, string>) (content : string) = ()

Finally, we want to define a body. The first part of any tag is starting it, or the <tagName bit. (Notice I excluded the closing bracket: this is going to be dealt with momentarily.) The <tagName bit should also have attributes if there are any, so we'll want <tagName attr="value". To do this, we can actually map our attributes to an array, then map them to key=\"value\", then join them on a space, then add space if there are any, then finally we can print the starting tag:

let renderTag_v3_3 (selfClose : bool) (includeBreaks : bool) (tagName : string) (attrs : Map<string, string>) (content : string) =
    let tagStart =
        attrs
        |> Map.toArray
        |> Array.map (fun ((k : string), (v : string)) -> sprintf "%s=\"%s\"" (k.ToLower()) (v.Replace("\"", "\\\"")))
        |> joinStrings " "
        |> prependIfText " "
        |> sprintf "<%s%s" tagName
    tagStart

Once again, we're making decent progress. We've followed the XHTML convention, of lower-casing the key, which is also entirely valid for HTML. (Conveniently.)

Next, if the content is empty, we want to either self-close or explictly close the tag. This is accomplished by a simple if.

let renderTag_v3_4 (selfClose : bool) (includeBreaks : bool) (tagName : string) (attrs : Map<string, string>) (content : string) =
    let tagStart =
        attrs
        |> Map.toArray
        |> Array.map (fun ((k : string), (v : string)) -> sprintf "%s=\"%s\"" (k.ToLower()) (v.Replace("\"", "\\\"")))
        |> joinStrings " "
        |> prependIfText " "
        |> sprintf "<%s%s" tagName
    if content |> System.String.IsNullOrEmpty then
        if selfClose then sprintf "%s />" tagStart
        else sprintf "%s></%s>" tagStart tagName
    else 
        tagStart

In our else branch, when there is content, we want to test it for any line-breaks, and if we should include them do so:

let renderTag_v3_5 selfClose includeBreaks tagName attrs content =
    let tagStart =
        attrs
        |> Map.toArray
        |> Array.map (fun ((k : string), (v : string)) -> sprintf "%s=\"%s\"" (k.ToLower()) (v.Replace("\"", "\\\"")))
        |> joinStrings " "
        |> prependIfText " "
        |> sprintf "<%s%s" tagName
    if content |> System.String.IsNullOrEmpty then
        if selfClose then sprintf "%s />" tagStart
        else sprintf "%s></%s>" tagStart tagName
    else
        let tagStart = sprintf "%s>" tagStart
        let breakV = if includeBreaks then System.Environment.NewLine else ""
        let tagEnd = sprintf "</%s>" tagName
        sprintf "%s%s%s%s%s%s" tagStart breakV content breakV tagEnd breakV

So now that gets our main tag-rendering started. The next bit is to actually build prototypes for each main tag:

let renderTitle_v3 = renderTag_v3_5 false false "title" Map.empty<string, string>
let renderHead_v3 = renderTag_v3_5 false true "head" Map.empty<string, string>
let renderBody_v3 = renderTag_v3_5 false true "body"

As you can see, each tag has specific expectations. Our <title> tag has no line-breaks, and does not allow attributes, whereas our <head> tag has line-breaks, and does not allow attributes. Our <body> tag has both.

We have another utility method to define:

let stringOrBlank = function | Some s -> s | None -> ""

Which will make sense in a moment.

The next step is to render the actual document. This is relatively easy, render the <head>, render the <body>, and render the <!DOCTYPE>. Because we have 3 major HTML document-types, and each has different rules, we'll define a function for each:

let getStrictBody_v3 (document : StrictDocument_V3) =
    let sb = System.Text.StringBuilder()
    document.Head.Title |> renderTitle_v3 |> renderHead_v3 |> sb.Append |> ignore
    document.Body |> stringOrBlank |> renderBody_v3 ([] |> Map.ofList) |> sb.Append |> ignore
    sb.ToString()
let getTransitionalBody_v3 (document : TransitionalDocument_V3) =
    let sb = System.Text.StringBuilder()
    document.Head.Title |> renderTitle_v3 |> renderHead_v3 |> sb.Append |> ignore
    document.Body |> stringOrBlank |> renderBody_v3 ([] |> Map.ofList) |> sb.Append |> ignore
    sb.ToString()
let getFramesetBody_v3 (document : FramesetDocument_V3) =
    let sb = System.Text.StringBuilder()
    document.Head.Title |> renderTitle_v3 |> renderHead_v3 |> sb.Append |> ignore
    document.Body |> stringOrBlank |> renderBody_v3 ([] |> Map.ofList) |> sb.Append |> ignore
    sb.ToString()

Now we see how things start to fit together, and we still have to return one more larger document for the full <html> bit:

let getBody_v3 document =
    match document with
    | XhtmlDocument (Strict d) | Html4Document (Strict d) | Html5Document d -> d |> getStrictBody_v3
    | XhtmlDocument (Transitional d) | Html4Document (Transitional d) -> d |> getTransitionalBody_v3
    | XhtmlDocument (Frameset d) | Html4Document (Frameset d) -> d |> getFramesetBody_v3

Of course, it's obvious this isn't handling the <html> bit, this just calls the next renderer.

let printDocument_v3 document =
    let doctype = document |> getDoctype_v3
    let sb = System.Text.StringBuilder()
    doctype |> sb.Append |> ignore
    System.Environment.NewLine |> sb.Append |> ignore
    let attrs =
        match document with
        | Html4Document _ | Html5Document _ -> [] |> Map.ofList
        | XhtmlDocument _ -> [("xmlns", "http://www.w3.org/1999/xhtml")] |> Map.ofList
    document |> getBody_v3 |> renderTag_v3_5 false true "html" attrs |> sb.Append |> ignore
    sb.ToString()

While this is a great start, we haven't fully supported our model. We don't render the <meta> tags I promised. To do that, we have to add a little more code (though not much). For these we'll abstract up our <head> rendering another level, because we need to render sequences in the <head> tag.

let renderMetaTag_v4 = renderTag_v3_5 true false "meta"
let getCharset_v4 c =
    match c with
    | Charset_V3.Utf8 -> "utf-8"

let getStandardMetaAttrs_v4 m =
    let result s = [("name", s)]
    match m with
    | StandardMeta_V3.ApplicationName lang -> lang |> (function | Some l -> [("lang", l)] | _ -> []) |> List.append [("name", "application-name")]
    | Author -> "author" |> result
    | Description -> "description" |> result
    | Generator -> "generator" |> result
    | Keywords -> "keywords" |> result
    | Referrer -> "referrer" |> result

let getHead_v4 head =
    let sb = System.Text.StringBuilder()
    head.Title |> renderTitle_v3 |> sb.Append |> ignore
    match head.Charset with
    | Some c ->
        let charset = c |> getCharset_v4
        renderMetaTag_v4 ([("content", (sprintf "text/html; charset=%s" charset)); ("http-equiv", "Content-Type")] |> Map.ofList) "" |> sb.Append |> ignore
    | None -> ()
    head.StandardMetas |> Map.toArray |> Array.map (fun (k, v) -> renderMetaTag_v4 ([("content", v)] |> List.append (k |> getStandardMetaAttrs_v4) |> Map.ofList) "") |> Array.iter (sb.Append >> ignore)
    sb.ToString() |> renderHead_v3

let getStrictBody_v4 (document : StrictDocument_V3) =
    let sb = System.Text.StringBuilder()
    document.Head |> getHead_v4 |> sb.Append |> ignore
    document.Body |> stringOrBlank |> renderBody_v3 ([] |> Map.ofList) |> sb.Append |> ignore
    sb.ToString()
let getTransitionalBody_v4 (document : TransitionalDocument_V3) =
    let sb = System.Text.StringBuilder()
    document.Head |> getHead_v4 |> sb.Append |> ignore
    document.Body |> stringOrBlank |> renderBody_v3 ([] |> Map.ofList) |> sb.Append |> ignore
    sb.ToString()
let getFramesetBody_v4 (document : FramesetDocument_V3) =
    let sb = System.Text.StringBuilder()
    document.Head |> getHead_v4 |> sb.Append |> ignore
    document.Body |> stringOrBlank |> renderBody_v3 ([] |> Map.ofList) |> sb.Append |> ignore
    sb.ToString()

With all that done, we should get the apporpriate result with our "standard" meta-tags returned in the result output. This demonstrates how truly easy it is to modify this system to add features.

Now we haven't even come close to finishing with the <head> section, nor even close to fulfilling even the most common elements of it. For that, we'll actually add a couple more properties to our record type.

A <head> section in an (X)HTML page often consists of stylesheets and JavaScript as well as the items we've already included. Fortunately, including support for those two sections is bewilderingly easy. We'll just create two new properties on our Head type, and we'll also add a new Union type to indicate if they're a file, or the actual script.

There are two ways to include stylesheets and JavaScript: you can include a reference to a file that holds the information, or you can include the raw information. Supporting both here is extremely easy:

type Resource_V5 = | File of Name : string | Data of RawData : string

So now, we could actually create a JavaScript section to our Head:

type Head_V5 = { Title : string; Charset : Charset_V3 option; StandardMetas : Map<StandardMeta_V3, string>; Scripts : Resource_V5 list; Stylesheets : Resource_V5 list }

That's easy enough. I also included the stylesheets, because both will use the same union type, with different values. Now we can create a new document with these specified:

type StrictDocument_V5 = { Head : Head_V5; Body : string option }
type TransitionalDocument_V5 = { Head : Head_V5; Body : string option }
type FramesetDocument_V5 = { Head : Head_V5; Body : string option }
type DocumentForm_V5 = | Strict of StrictDocument_V5 | Transitional of TransitionalDocument_V5 | Frameset of FramesetDocument_V5
type Document_V5 = | Html5Document of StrictDocument_V5 | Html4Document of DocumentForm_V5 | XhtmlDocument of DocumentForm_V5
let html5Document_v5 =
    Document_V5.Html5Document
      { StrictDocument_V5.Head =
          { Head_V5.Title = "A Test Document"
            Charset = Some Charset_V3.Utf8
            StandardMetas = [(StandardMeta_V3.ApplicationName (Some "en"), "Test Application"); (StandardMeta_V3.Description, "A test application.")] |> Map.ofList
            Scripts = [Resource_V5.File "somepath/file.js"; Resource_V5.Data "alert(\"Test script!\");"]
            Stylesheets = [] }
        Body = None }

Now we just have to render these, which is only a slight change to our getHead function:

let renderScript_v5 s =
    match s with
    | Resource_V5.File f -> renderTag_v3_5 false false "script" ([("type", "text/javascript"); ("src", f)] |> Map.ofList) ""
    | Data d -> renderTag_v3_5 false true "script" ([("type", "text/javascript")] |> Map.ofList) d
let renderStyle_v5 s =
    match s with
    | Resource_V5.File f -> renderTag_v3_5 true false "link" ([("rel", "stylesheet"); ("type", "text/css"); ("href", f)] |> Map.ofList) ""
    | Data d -> renderTag_v3_5 true true "style" ([("type", "text/css")] |> Map.ofList) d
let getHead_v5 head =
    let sb = System.Text.StringBuilder()
    let render (s : string) =
        s |> sb.Append |> ignore
        System.Environment.NewLine |> sb.Append |> ignore
    head.Title |> renderTitle_v3 |> render
    match head.Charset with
    | Some c ->
        let charset = c |> getCharset_v4
        "" |> render
        renderMetaTag_v4 ([("content", (sprintf "text/html; charset=%s" charset)); ("http-equiv", "Content-Type")] |> Map.ofList) "" |> sb.Append |> ignore
    | None -> ()
    match head.StandardMetas with
    | m when m.IsEmpty -> ()
    | m ->
        "" |> render
        m |> Map.toArray |> Array.map (fun (k, v) -> renderMetaTag_v4 ([("content", v)] |> List.append (k |> getStandardMetaAttrs_v4) |> Map.ofList) "") |> Array.iter render
    match head.Stylesheets with
    | [] -> ()
    | s ->
        "" |> render
        s |> List.map renderStyle_v5 |> List.iter render
    match head.Scripts with
    | [] -> ()
    | s ->
        "" |> render
        s |> List.map renderScript_v5 |> List.iter render
    sb.ToString() |> renderHead_v3

let getStrictBody_v5 (document : StrictDocument_V5) =
    let sb = System.Text.StringBuilder()
    document.Head |> getHead_v5 |> sb.Append |> ignore
    document.Body |> stringOrBlank |> renderBody_v3 ([] |> Map.ofList) |> sb.Append |> ignore
    sb.ToString()
let getTransitionalBody_v5 (document : TransitionalDocument_V5) =
    let sb = System.Text.StringBuilder()
    document.Head |> getHead_v5 |> sb.Append |> ignore
    document.Body |> stringOrBlank |> renderBody_v3 ([] |> Map.ofList) |> sb.Append |> ignore
    sb.ToString()
let getFramesetBody_v5 (document : FramesetDocument_V5) =
    let sb = System.Text.StringBuilder()
    document.Head |> getHead_v5 |> sb.Append |> ignore
    document.Body |> stringOrBlank |> renderBody_v3 ([] |> Map.ofList) |> sb.Append |> ignore
    sb.ToString()

let getBody_v5 document =
    match document with
    | XhtmlDocument (Strict d) | Html4Document (Strict d) | Html5Document d -> d |> getStrictBody_v5
    | XhtmlDocument (Transitional d) | Html4Document (Transitional d) -> d |> getTransitionalBody_v5
    | XhtmlDocument (Frameset d) | Html4Document (Frameset d) -> d |> getFramesetBody_v5

let getDoctype_v5 document =
    match document with
    | Document_V5.XhtmlDocument (Strict _) -> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
    | XhtmlDocument (Transitional _) -> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"
    | XhtmlDocument (Frameset _) -> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
    | Html4Document (Strict _) -> "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
    | Html4Document (Transitional _) -> "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">"
    | Html4Document (Frameset _) -> "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">"
    | Html5Document _ -> "<!DOCTYPE HTML>"

let printDocument_v5 (document : Document_V5) =
    let doctype = document |> getDoctype_v5
    let sb = System.Text.StringBuilder()
    doctype |> sb.Append |> ignore
    System.Environment.NewLine |> sb.Append |> ignore
    let attrs =
        match document with
        | Html4Document _ | Html5Document _ -> [] |> Map.ofList
        | XhtmlDocument _ -> [("xmlns", "http://www.w3.org/1999/xhtml")] |> Map.ofList
    document |> getBody_v5 |> renderTag_v3_5 false true "html" attrs |> sb.Append |> ignore
    sb.ToString()

let writeFile f c = System.IO.File.WriteAllText(System.IO.Path.Combine(__SOURCE_DIRECTORY__, f), c)
html5Document_v5 |> printDocument_v5 |> writeFile "TestFile.html"

With all of this, our work starts to come together nicely. We want to test it with an XHTML document as well, which is just as easy:

let xhtml1Document_v5 =
    Document_V5.XhtmlDocument
      (DocumentForm_V5.Strict
          { StrictDocument_V5.Head =
              { Head_V5.Title = "A Test Document"
                Charset = Some Charset_V3.Utf8
                StandardMetas = [(StandardMeta_V3.ApplicationName (Some "en"), "Test Application"); (StandardMeta_V3.Description, "A test application.")] |> Map.ofList
                Scripts = [Resource_V5.File "somepath/file.js"; Resource_V5.Data "alert(\"Test script!\");"]
                Stylesheets = [] }
            Body = None } )
xhtml1Document_v5 |> printDocument_v5 |> writeFile "TestFile.html"

Next, we want to add support for non-standard <meta> tags, which is extremely easy:

type Head_V6 = { Title : string; Charset : Charset_V3 option; StandardMetas : Map<StandardMeta_V3, string>; AdditionalMetas : Map<string, string>; Scripts : Resource_V5 list; Stylesheets : Resource_V5 list }

let getHead_v6 head =
    let sb = System.Text.StringBuilder()
    let render (s : string) =
        s |> sb.Append |> ignore
        System.Environment.NewLine |> sb.Append |> ignore
    head.Title |> renderTitle_v3 |> render
    match head.Charset with
    | Some c ->
        let charset = c |> getCharset_v4
        "" |> render
        renderMetaTag_v4 ([("content", (sprintf "text/html; charset=%s" charset)); ("http-equiv", "Content-Type")] |> Map.ofList) "" |> sb.Append |> ignore
    | None -> ()
    match head.StandardMetas with
    | m when m.IsEmpty -> ()
    | m ->
        "" |> render
        m |> Map.toArray |> Array.map (fun (k, v) -> renderMetaTag_v4 ([("content", v)] |> List.append (head.AdditionalMetas |> Map.toList) |> List.append (k |> getStandardMetaAttrs_v4) |> Map.ofList) "") |> Array.iter render
    match head.Stylesheets with
    | [] -> ()
    | s ->
        "" |> render
        s |> List.map renderStyle_v5 |> List.iter render
    match head.Scripts with
    | [] -> ()
    | s ->
        "" |> render
        s |> List.map renderScript_v5 |> List.iter render
    sb.ToString() |> renderHead_v3

You'll notice the only thing I changed is to add a List.append (head.AdditionalMetas |> Map.toList) in our standard meta printing, because the standard metas are, at that point, string * string. This means we can guarantee it works because we used the exact same code to do both. By taking the combined list back to a Map, we guarantee that each key is specified exactly once even among the combined lists.

We have one more part of the <head> tag I want to go over, and that's the presence of a <base> tag. This is where we'll see a divide between the XHTML and HTML specifications, as they have different allowable options.

For XHTML 1.0, the <base> tag is allowed to have an href attribute, that specifies what the base URL is for relative navigation. (I.e. if you provide a link to somepage.html, the <base href="http://www.example.com/"> tag will make that a link to http://www.example.com/somepage.html.)

In HTML, the following unions would satisfy our <base> tag requirements:

type HrefTarget_V7 = | SameContextWindow | NewCleanContext | ParentContext | TopMostContext
type HtmlBaseElement_V7 = | Href of string | Target of HrefTarget_V7 | HrefTarget of string * HrefTarget_V7

In XHTML, it's only allowed to be a Href or not specified. For that, we'll define some new <head> models:

type HtmlHead_V7 = {
    Title : string
    Base : HtmlBaseElement_V7 option
    Charset : Charset_V3 option
    StandardMetas : Map<StandardMeta_V3, string>
    AdditionalMetas : Map<string, string>
    Stylesheets : Resource_V5 list
    Scripts : Resource_V5 list }
type XhtmlHead_V7 = {
    Title : string
    Base : string option
    Charset : Charset_V3 option
    StandardMetas : Map<StandardMeta_V3, string>
    AdditionalMetas : Map<string, string>
    Stylesheets : Resource_V5 list
    Scripts : Resource_V5 list }

Obviously this means we will now have two different head models, which means we will need two different renderers, and two different sets of document types, etc. While we're at it, we may-as-well start defining the Body type, which will hold our main content.

type Body_V7 = { Attributes : Map<string, string>; Children : string option }
type HtmlFramesetDocument_V7 = { Head : HtmlHead_V7; Body : Body_V7 }
type HtmlTransitionalDocument_V7 = { Head : HtmlHead_V7; Body : Body_V7 }
type HtmlStrictDocument_V7 = { Head : HtmlHead_V7; Body : Body_V7 }
type XhtmlFramesetDocument_V7 = { Head : XhtmlHead_V7; Body : Body_V7 }
type XhtmlTransitionalDocument_V7 = { Head : XhtmlHead_V7; Body : Body_V7 }
type XhtmlStrictDocument_V7 = { Head : XhtmlHead_V7; Body : Body_V7 }
type HtmlDocumentForm_V7 = | Frameset of HtmlFramesetDocument_V7 | Transitional of HtmlTransitionalDocument_V7 | Strict of HtmlStrictDocument_V7
type XhtmlDocumentForm_V7 = | Frameset of XhtmlFramesetDocument_V7 | Transitional of XhtmlTransitionalDocument_V7 | Strict of XhtmlStrictDocument_V7
type WebDocument_V7 = | Html5Document of HtmlStrictDocument_V7 | Html4Document of HtmlDocumentForm_V7 | XhtmlDocument of XhtmlDocumentForm_V7
let getDoctype_v7 document =
    match document with
    | XhtmlDocument (XhtmlDocumentForm_V7.Strict _) -> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
    | XhtmlDocument (XhtmlDocumentForm_V7.Transitional _) -> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"
    | XhtmlDocument (XhtmlDocumentForm_V7.Frameset _) -> "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
    | Html4Document (HtmlDocumentForm_V7.Strict _) -> "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
    | Html4Document (HtmlDocumentForm_V7.Transitional _) -> "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">"
    | Html4Document (HtmlDocumentForm_V7.Frameset _) -> "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">"
    | Html5Document _ -> "<!DOCTYPE HTML>"

As is obvious here, we're forcing the different between the document types to be more obvious. This is mostly due to our <head> tag issue, but we would have needed to do this anyway (and will do so for the <body> eventually). Now, fortunately, most of our boiler-plate will stay the same, except for the first couple steps of rendering:

let getTarget_v7 = function | SameContextWindow -> "_self" | NewCleanContext -> "_blank" | ParentContext -> "_parent" | TopMostContext -> "_top"

let getHtmlHead (head : HtmlHead_V7) =
    let sb = System.Text.StringBuilder()
    let render (s : string) =
        s |> sb.Append |> ignore
        System.Environment.NewLine |> sb.Append |> ignore
    head.Title |> renderTitle_v3 |> render
    match head.Charset with
    | Some c ->
        "" |> render
        renderMetaTag_v4 ([("content", c |> getCharset_v4 |> sprintf "text/html; charset=%s"); ("http-equiv", "Content-Type")] |> Map.ofList) "" |> render
    | None -> ()
    match head.Base with
    | Some b ->
        let attrs = 
            let href =
                match b with
                | Href h | HrefTarget (h, _) -> [("href", h)]
                | _ -> []
            let target = 
                match b with
                | Target t | HrefTarget (_, t) -> [("target", t |> getTarget_v7)]
                | _ -> []
            target |> List.append href |> Map.ofList
        "" |> render
        renderTag_v3_5 true false "base" attrs "" |> render
    | None -> ()
    match head.StandardMetas with
    | m when m.IsEmpty -> ()
    | m ->
        "" |> render
        m |> Map.toArray |> Array.map (fun (k, v) -> renderMetaTag_v4 ([("content", v)] |> List.append (head.AdditionalMetas |> Map.toList) |> List.append (k |> getStandardMetaAttrs_v4) |> Map.ofList) "") |> Array.iter render
    match head.Stylesheets with
    | [] -> ()
    | s ->
        "" |> render
        s |> List.map renderStyle_v5 |> List.iter render
    match head.Scripts with
    | [] -> ()
    | s ->
        "" |> render
        s |> List.map renderScript_v5 |> List.iter render
    sb.ToString() |> renderHead_v3

Now, interestingly, we can make XHTML head rendering really easy by converting it to an HTML head, at least for now.

let getXhtmlHead (head : XhtmlHead_V7) =
    { HtmlHead_V7.Title = head.Title
      Charset = head.Charset
      AdditionalMetas = head.AdditionalMetas
      Base = head.Base |> Option.map Href
      StandardMetas = head.StandardMetas
      Stylesheets = head.Stylesheets
      Scripts = head.Scripts }
    |> getHtmlHead

Then we need to define some new get___Body and such functions, which are going to be just as trivial as before.

let getHtmlStrictBody_v7 (document : HtmlStrictDocument_V7) =
    let sb = System.Text.StringBuilder()
    document.Head |> getHtmlHead |> sb.Append |> ignore
    document.Body.Children |> stringOrBlank |> sprintf "<div>%s</div>" |> renderBody_v3 document.Body.Attributes |> sb.Append |> ignore
    sb.ToString()
let getHtmlTransitionalBody_v7 (document : HtmlTransitionalDocument_V7) =
    let sb = System.Text.StringBuilder()
    document.Head |> getHtmlHead |> sb.Append |> ignore
    document.Body.Children |> stringOrBlank |> sprintf "<div>%s</div>" |> renderBody_v3 document.Body.Attributes |> sb.Append |> ignore
    sb.ToString()
let getHtmlFramesetBody_v7 (document : HtmlFramesetDocument_V7) =
    let sb = System.Text.StringBuilder()
    document.Head |> getHtmlHead |> sb.Append |> ignore
    document.Body.Children |> stringOrBlank |> sprintf "<div>%s</div>" |> renderBody_v3 document.Body.Attributes |> sb.Append |> ignore
    sb.ToString()
let getXhtmlStrictBody_v7 (document : XhtmlStrictDocument_V7) =
    let sb = System.Text.StringBuilder()
    document.Head |> getXhtmlHead |> sb.Append |> ignore
    document.Body.Children |> stringOrBlank |> sprintf "<div>%s</div>" |> renderBody_v3 document.Body.Attributes |> sb.Append |> ignore
    sb.ToString()
let getXhtmlTransitionalBody_v7 (document : XhtmlTransitionalDocument_V7) =
    let sb = System.Text.StringBuilder()
    document.Head |> getXhtmlHead |> sb.Append |> ignore
    document.Body.Children |> stringOrBlank |> sprintf "<div>%s</div>" |> renderBody_v3 document.Body.Attributes |> sb.Append |> ignore
    sb.ToString()
let getXhtmlFramesetBody_v7 (document : XhtmlFramesetDocument_V7) =
    let sb = System.Text.StringBuilder()
    document.Head |> getXhtmlHead |> sb.Append |> ignore
    document.Body.Children |> stringOrBlank |> sprintf "<div>%s</div>" |> renderBody_v3 document.Body.Attributes |> sb.Append |> ignore
    sb.ToString()

We also added a sprintf "<div>%s</div>" to maintain (X)HTML compliance in the <body> section while we develop. Then getBody becomes pretty simple:

let getBody_v7 document =
    match document with
    | Html4Document (HtmlDocumentForm_V7.Strict d) | Html5Document d -> d |> getHtmlStrictBody_v7
    | XhtmlDocument (XhtmlDocumentForm_V7.Strict d) -> d |> getXhtmlStrictBody_v7
    | Html4Document (HtmlDocumentForm_V7.Transitional d) -> d |> getHtmlTransitionalBody_v7
    | XhtmlDocument (XhtmlDocumentForm_V7.Transitional d) -> d |> getXhtmlTransitionalBody_v7
    | Html4Document (HtmlDocumentForm_V7.Frameset d) -> d |> getHtmlFramesetBody_v7
    | XhtmlDocument (XhtmlDocumentForm_V7.Frameset d) -> d |> getXhtmlFramesetBody_v7

But our printDocument doesn't change:

let printDocument_v7 document =
    let doctype = document |> getDoctype_v7
    let sb = System.Text.StringBuilder()
    doctype |> sb.Append |> ignore
    System.Environment.NewLine |> sb.Append |> ignore
    let attrs =
        match document with
        | Html4Document _ | Html5Document _ -> [] |> Map.ofList
        | XhtmlDocument _ -> [("xmlns", "http://www.w3.org/1999/xhtml")] |> Map.ofList
    document |> getBody_v7 |> renderTag_v3_5 false true "html" attrs |> sb.Append |> ignore
    sb.ToString()

let xhtmlDocument_v7 =
    XhtmlDocument (
        Strict {
            XhtmlStrictDocument_V7.Head =
              { Title = "Test"
                Base = Some "http://example.com/"
                Charset = Some Utf8
                StandardMetas = [(ApplicationName None, "Test Application"); (Description, "A test application."); (Keywords, "test, application")] |> Map.ofList
                AdditionalMetas = [] |> Map.ofList
                Scripts = [File "test.js"]
                Stylesheets = [File "style.css"] }
            Body = { Attributes = [] |> Map.ofList; Children = Some "Test" }
        })

let html5Document_v7 =
    Html5Document {
        HtmlStrictDocument_V7.Head =
          { Title = "Test"
            Base = NewCleanContext |> Target |> Some
            Charset = Some Utf8
            StandardMetas = [(ApplicationName None, "Test Application"); (Description, "A test application."); (Keywords, "test, application")] |> Map.ofList
            AdditionalMetas = [] |> Map.ofList
            Scripts = [File "test.js"]
            Stylesheets = [File "style.css"] }
        Body = { Attributes = [] |> Map.ofList; Children = None }
    }

[xhtmlDocument_v7; html5Document_v7] |> List.map printDocument_v7 |> List.iter (writeFile "TestFile.html")

Ok, ok, so I've gone through a whole bunch of stuff here, but haven't really described what it all means. Here's the thing: the purpose of this post is to show you exactly what is possible with the F# type system. It's designed to show you that we can actually define and use types which create a safe environment to generate a completely different language. We described the basic types and processes which are used to generate HTML (at least in my solution) from F#. I'll be making this whole library (which is far better written than my poor examples here) open source in the coming weeks, but the basic idea is something I've been meaning to describe for some time. With the definitions we have, the next step would be to define parts that can be assembled, so that we could take an html5Document and add the appropriate master style-sheets or templating to it. We could take a document and convert it to a different type, with minimal issue. The goal of this library was to generate HTML, and offer compile-time safety of that generated HTML, and as you can see we are already accomplishing that for our <head>.

You also might be asking yourself what the advantage to something like this really is. "Elliott, it's not all that hard to write HTML, really." And you're absolutely correct, HTML is a pretty easy markup language to write, and browsers are quite forgiving, which means that even when you mess up it still works out mostly-OK, but why don't we try to do better? I use this system to generate my HTML because it gives me three major benefits:

Generate partial templates to be combined in later stages with ease;
Ensure compliance with the HTML specification and that we don't forget to close the appropriate tags;
Allow layout swaps and transitions with a much higher ease;

And I'm not sure about you, but these are the same reasons I use F# when I can, it gives me these same benefits.

Now I could continue to go on about how we would design this templating system, but I won't. It's overly excessive explanation for not-a-lot of benefit. Instead, I'll conclude our discussion here and when this is released, then I'll go through more of how-to-use it and why you might want to.

Until then, farewell, and I hope everyone enjoys the holiday season! ☃☃☃

`using` Programming;

A Blog about some of the intrinsics related to programming and how one can get the best out of various languages.

Doing Bad Cookie Authentication, but for the Right Reasons

Poor Cookie-Based Authentication with ASP.NET

What is a cookie?

Cookie-Based Authentication in ASP.NET

Step 1: Create the `Authenticated.aspx`

Step 2: `Login.aspx`

Step 3: Our `Default.aspx` with logout

Authentication complete!

Cookie-Based Authentication Insecurities

Automating our Tests

An Ideal World

Constructing an IMAP Server from Scratch - Part 2

Implementing Server-Side RFC 3501 (IMAP) in F# (Part 2)

Building a Configuration File

Building Storage Events

Implementing IMAP Commands

Constructing an IMAP Server from Scratch - Part 1

Implementing Server-Side RFC 3501 (IMAP) in F# (Part 1)

Start with RTFM (or RFC's, in this case)

What is IMAP?

Getting Started: Understanding Requirements

Let's start building a server!

Boilerplate

Build a TCP Server

Building the basic IMAP Server

Testing our Server

Building a Rashberry Pi Graphing Machine

Building the software for a Rasberry Pi Weather Instrument System

Step 1: Install MariaDB and Apache with Python

Step 2: Create a database

Step 3: Log to the Database

Step 4: Setup graphing (this is the fun part)

F# Advent Day of Code: Modeling types to prevent bugs

F# Advent Day of Code: Taking advantage of the F# Type-System

Step 1: same as usual, identify the problem

Step 2: solve the problem

Mon	Tue	Wed	Thu	Fri	Sat	Sun
26	27	28	29	30	31	1
2	3	4	5	6	7	8
9	10	11	12	13	14	15
16	17	18	19	20	21	22
23	24	25	26	27	28	29
30	1	2	3	4	5	6

Poor Cookie-Based Authentication with ASP.NET

What is a cookie?

Cookie-Based Authentication in ASP.NET

Step 1: Create the Authenticated.aspx

Step 2: Login.aspx

Step 3: Our Default.aspx with logout

Authentication complete!

Cookie-Based Authentication Insecurities

Automating our Tests

An Ideal World

Implementing Server-Side RFC 3501 (IMAP) in F# (Part 2)

Building a Configuration File

Building Storage Events

Implementing IMAP Commands

Implementing Server-Side RFC 3501 (IMAP) in F# (Part 1)

Start with RTFM (or RFC's, in this case)

What is IMAP?

Getting Started: Understanding Requirements

Let's start building a server!

Boilerplate

Build a TCP Server

Building the basic IMAP Server

Testing our Server

Building the software for a Rasberry Pi Weather Instrument System

Step 1: Install MariaDB and Apache with Python

Step 2: Create a database

Step 3: Log to the Database

Step 4: Setup graphing (this is the fun part)

F# Advent Day of Code: Taking advantage of the F# Type-System

Step 1: same as usual, identify the problem

Step 2: solve the problem

Step 1: Create the `Authenticated.aspx`

Step 2: `Login.aspx`

Step 3: Our `Default.aspx` with logout