[info] FormattersSpec
[info]   Formatters are invertible for:
[info]     + Mapping
[info]     + Identifier
[info]
[error]     x Metadata
[error]  Gave up after only 39 passed tests. 197 tests were discarded. (FormattersSpec.scala:11)

This test generates random Metadata values and makes sure that they can be serialised and deserialised correctly (i.e. values can be round-tripped). The property being test here is identical, only the Arbitrary, Serialise, and Deserialise instances vary in each case. The truly odd thing is that the pertinent code looks like this:

case class Identifier(name: String)
case class Metadata (id: Identifier, maps: Set[Identifier])

implicit val ArbIdentifier = Arbitrary(
  for {
    name  <- arbitrary[String]
  } yield Identifier(name)
)

implicit val ArbMetadata = Arbitrary(
  for {
    identifier <- arbitrary[Identifier]
    mappings   <- arbitrary[Set[Identifier]]
  } yield Metadata(identifier, mappings)
)

My first step was redefining a few related Arbitrary instances to avoid using suchThat (which discards invalid values) but this didn’t fix the problem. Eventually I tried redefining ArbMetadata like this:

implicit val ArbMetadata = Arbitrary(
  for {
    identifier <- arbitrary[Identifier]
    mappings   <- Gen.const(Set.empty[Set[Identifier]])
  } yield Metadata(identifier, mappings)
)

and the problem went away. Trying to use arbitrary[Set[Identifier]] in various ways in the Scala REPL confirmed that it is the problem; we can easily generate as large a List[Identifier] as we like, but a Set[Identifier] fails fairly frequently:

// This always generates a Some[List[Identifier]] value.
Gen.listOfN(100, arbitrary[Identifier]).map(_.length).sample
// Sometimes we get a Some[List[Set[Identifier]]] and others None.
Gen.listOfN(100, arbitrary[Set[Identifier]]).map(_.length).sample

It appears as though whatever mechanism is used by arbitrary[Set[_]] to construct the sets, it doesn’t fails when the generator for the value type returns duplicate elements. You can confirm this easily by trying arbitrary[Set[Unit]]; any Gen[Unit] has no choice but to return a the single value of type Unit (or to fail) and, as expected, this almost never succeeds. Replacing the problematic arbitrary[Set[Identifier]] in the original code with arbitrary[Seq[Identifier]].map(_.toSet) resolves the issue: constructing a set from a list of possibly duplicate Identifiers always works.

After a bit of reading in the ScalaCheck source code it seems as though the root cause of this problem is some instance of CanBuildFrom[Set[_], A, Set[A]] but I’ve no idea how to go about figure out which one or why it’s broken. In any case, I now know a bit more about working with Scala.

For more information, see the ScalaCheck issue #89.

Multiple versions of GHC on Travis CI

Travis CI, for those who aren’t familiar with it, is a continuous integration service with pretty tight integration with GitHub. Using it is pretty straightforward: you add a YAML file to your repository describing how to test your project and then you turn it on. Using matrix variables in your YAML file you can specify multiple values for various aspects of your build process and Travis CI will run your job multiple times - once for each combination of values. The standard approach to testing with multiple GHC versions on Travis CI uses this to specify which versions of GHC and Cabal to install and use in the build; specify four versions and get run four times. Magic!

The .travis.yml file you use to do this is a little more complex than the usual one saying “make my Haskell go!”, but you can generally just copy it around from project to project. I edited my .travis.yml file slightly to tweak the way Travis CI sends me email and to select the versions of GHC that I care about and now every build for that project automatically covers all the cases I care about.

So what?

My edit-distance-vector package is very simple: it’s one module with 166 lines (including comments and white space) and 100 lines of tests (again, including comments and white space). Here are the issues picked up by testing with four versions of GHC:

1. Obviously, the version bounds on the base library need to be broadened. I’ve used base >=4.5 && <4.9 now.

2. Next I learn that the Sum type didn’t have a Num instance in earlier versions. This means that constants like 1 can’t have types like Sum Int so I’ve just applied the Sum constructor manually: Sum 1.

3. Then I learned that importing a module hiding something that it doesn’t export used to be an error (it is now a warning).

The commit fixing these issues is pretty trivial but made the library usable in a wider range of environments. Yay!

I think I’ll be using this by default in new Haskell repositories; when my code doesn’t work with some version of GHC I’d like it to be because I decided to do it, not just that I didn’t know.

The edit-distance-vector package is a small library for calculating the optimal edit script and cost to transform one sequence of values into another. The implementation uses the Wagner-Fischer algorithm and the rather fun constructN function.

I have a draft blog post on the way about the details of this package but until that’s done you’ll have to make do with the documentation.

aeson-diff

The aeson-diff package includes a library and two command-line programs for extracting the differences between two JSON documents and for applying these changes. The commands are:

• aeson-diff which compares two JSON documents and generates a patch describing the differences between them; and

• aeson-patch which takes a JSON document and updates it according to patch.

I find the aeson-diff command quite useful for comparing different versions of the JSON documents spewed out by several systems I have to deal with at work.

import System.Exit
import System.Process

main :: IO ()
main = do
    let p = (shell "cat /usr/share/dict/words")
            { std_in  = Inherit
            , std_out = CreatePipe
            , std_err = Inherit
            }
    (Nothing, Just out, Nothing, ph) <- createProcess p
    ec <- waitForProcess ph
    case ph of
        ExitSuccess   -> hGetContents out >>= print
        ExitFailure _ -> error "Bad things happened. :-("

There is a potential problem in this code: we wait until the process has terminated before reading the Handle allowing its output to accumulate in the pipe buffer managed by the operating system in the mean time. This buffer has a fixed size on most systems (this is a good thing!); when it fills up, the writing process will go to sleep until the reader has consumed some data and freed some buffer space to hold the next write. Alas, the reader (the Haskell code above) is sleeping, waiting for the writer to terminate. The reader is sleeping, waiting for the writer to terminate; and the writer is sleeping, waiting for the reader to read. This is a deadlock!

The solution is to do the Right Thing (tm) and take care of any buffering behaviour we want ourselves. Thankfully this is pretty straightforward and it’s the sort of code you generally only need to write once. The very simplest case – reading from a process with a single output Handle – looks like this:

gatherOutput :: ProcessHandle -> Handle -> IO (ExitCode, ByteString)
gatherOutput ph h = work mempty
  where
    work acc = do
        -- Read any outstanding input.
        bs <- BS.hGetNonBlocking h (64 * 1024)
        let acc' = acc <> bs
        -- Check on the process.
        s <- getProcessExitCode ph
        -- Exit or loop.
        case s of
            Nothing -> work acc'
            Just ec -> do
                -- Get any last bit written between the read and the status
                -- check.
                last <- BS.hGetContents h
                return (ec, acc' <> last)

This is essentially a loop which reads some input from the Handle (possibly an empty string), checks to see if the process has terminated, and either returns the accumulated input or loops again. Extending this to gather the output of two handles (like stderr and stdout) is relatively straightforward.

I’ll start with some data types to represent the data my API manages. In this post I’ll use the example of a painting robot. The robot can carry several colours of paint but can only paint with one “active” colour at a time. Here are some data types to represent these details:

newtype ColourName = ColourName { unColourName :: Text }
  deriving (Eq, Show)

data Colour = Colour
    { colorName :: ColourName
    , colourRGB :: (Word8, Word8, Word8)
    }
  deriving (Eq, Show)

newtype RobotName = RobotName { unRobotName :: Text }
  deriving (Eq, Show)

data Robot = Robot
    { robotName :: RobotName
    , robotActiveColour :: ColourName
    , robotAvailableColours :: [Colour]
    }

JSON for the API clients

The JSON encoding of Robot that I’d like to provide to API clients is pretty straightforward:

{ "name" : "Rosie the robot"
, "activeColour" : "red"
, "availableColours" :
    { "red"   : { "R": 255, "G":   0, "B":   0}
    , "green" : { "R":   0, "G": 255, "B":   0}
    , "blue"  : { "R":   0, "G":   0, "B": 255}
    }
}

The Haskell code to parse this JSON using aeson is straightforward too (though please note that the instances derived for the newtype are only safe to use within a larger JSON structure as they result in bare JSON strings, not objects or arrays):

deriving instance FromJSON ColourName
deriving instance ToJSON ColourName

instance FromJSON [Colour] where
    parseJSON (Object v) = mapM (uncurry colour) $ HashMap.toList v
      where
        colour name (Object o) = Colour
                <$> parseJSON (String name)
                <*> ((,,) <$> o .: "R" <*> o .: "G" <*> o .: "B")
        colour _ _ = fail "Colour must be a JSON object"
    parseJSON _ = fail "Colours must be a JSON object"

deriving instance FromJSON RobotName
deriving instance ToJSON RobotName

instance FromJSON Robot where
    parseJSON (Object v) = Robot
        <$> v .: "name"
        <*> v .: "activeColour"
        <*> v .: "availableColours"
    parseJSON _ = fail "Robot must be a JSON object"

To talk to the upstream system I’ll use the process library to execute a command which produces JSON on its standard output. A simple function to invoke a command, parse the JSON, and return the value (or an error) keeps the boilerplate contained:

shellOutJSON
    :: (MonadError String m, MonadIO m, FromJSON a)
    => String
    -> [String]
    -> m a
shellOutJSON cmd args = do
    -- Execute the command.
    (exit_code, out, _err) <- liftIO $ readProcessWithExitCode cmd args ""

    -- Check it succeeded.
    output <- case exit_code of
        ExitSuccess -> return $ BS.pack out
        ExitFailure err -> throwError $
            "Could not execute command: error " <> show err

    -- Decode the JSON.
    case eitherDecode output of
        Left e -> throwError $ "Error decoding JSON: " <> e
        Right v -> return v

It’s important to note that the call site is responsible for fixing the type a of value to be parsed from the JSON. This means that shellOutJSON will happily attempt to parse the JSON into any type you ask it to (so long as it has a FromJSON instance), whether or not you should expect the command to produce such JSON. The obvious potential problem – a caller asking for data in the wrong format – occurred twice in a dozen lines of code in my current project.

JSON for the upstream system

The second JSON encoding is the one used to communicate with the command-line application. The main difference from the API encoding is that it represents the active colour by adding a status property to each colours; exactly one of them is active and the rest are available. Rosie the robot is looks like this:

{ "name" : "Rosie the robot"
, "colours" :
    { "red"   : { "R": 255, "G":   0, "B":   0, "status": "active"}
    , "green" : { "R":   0, "G": 255, "B":   0, "status": "available"}
    , "blue"  : { "R":   0, "G":   0, "B": 255, "status": "available"}
    }
}

This is structure is great if you are using the data to output a nice table for a human to read but not so great in an API.

This additional format could be implemented with new data types to represent robots and colours and a few conversion functions (probably using the excellent lens package) to represent the weirdly formatted versions of our types. Or I could keep the same data types but create a newtype wrapper around each of them with new FromJSON instances implementing the new format.

Instead I’ll add a “wrapper” type with which to distinguish a normal Robot from one which should be formatted for the upstream system.

data Upstream a = Upstream { unwrapUpstream :: a }

This new type doesn’t “do” anything, it just tags the value it wraps and lets me distinguish a Robot from an Upstream Robot which should be formatted for the API and the upstream system respectively. (This is not strictly true: it does take up memory and does cost an additional pointer dereference to traverse). With the new Upstream type I can write a second FromJSON instance each of my types.

If there is no special upstream format for a type the new instance can just call the existing instance and stuff the result in an Upstream wrapper:

instance FromJSON (Upstream [Colour]) where
    parseJSON j = Upstream <$> parseJSON j

When the upstream encoding and the API encoding do differ, I write a FromJSON instance in exactly the same way I normally would (making sure to use the Upstream version of any other FromJSON instances I use):

instance FromJSON (Upstream Robot) where
    parseJSON (Object v) = Upstream <$>
        (Robot
            <$>  v .: "name"
            <*> (v .: "colours" >>= activeColours >>= exactlyOne)
            <*> (unwrapUpstream <$> v .: "colours"))
      where
        -- Parse a JSON object of colours into a list of 'ColourName's which
        -- have @status == "active".
        activeColours :: Value -> Parser [ColourName]
        activeColours (Object o) = (fmap fst . filter snd) <$>
            mapM (uncurry colour) (HM.toList o)
        activeColours _ = fail "Colours must be a JSON object."

        -- Given a name and a JSON value, parse a pair containing the name and
        -- whether the colour has @status == "active"@.
        colour :: Text -> Value -> Parser (ColourName, Bool)
        colour name (Object o) = (,)
            <$> parseJSON (String name)
            <*> ((String "active" ==) <$> (o .: "status"))
        colour _ _ = fail "Colour must be a JSON object."

    parseJSON _ = fail "Robot must be a JSON object"

-- | Parser to check that a list contains exactly one value.
exactlyOne :: [a] -> Parser a
exactlyOne [] = fail "Missing value"
exactlyOne [a] = pure a
exactlyOne _ = fail "More than one value"

With all these instances written I can update shellOutJSON to use the Upstream instances when it interacts with the command-line program. Two small changes – adding Upstream to the FromJSON constraint and the “success” pattern match – are enough to ensure that all communication with the upstream system uses the Upstream JSON encoding:

shellOutJSON
    :: (MonadError String m, MonadIO m, FromJSON (Upstream a))
    => [String]
    -> m a
shellOutJSON cmd = do
    -- Execute the command.
    (exit_code, out, _err) <- liftIO $ readProcessWithExitCode cmd [] ""

    -- Check it succeeded.
    output <- case exit_code of
        ExitSuccess -> return $ BS.pack out
        ExitFailure err -> throwError $
            "Could not execute command: errno = " <> show err

    -- Decode the JSON.
    case eitherDecode output of
        Left e -> throwError $ 
            "Error decoding JSON: " <> e
        Right (Upstream v) -> return v

Now any call to shellOutJSON will automatically parse using the correct JSON encoding and any existing code using shellOutJSON doesn’t have to change. Even better, any call which needs a type without an Upstream instance of FromJSON will result in a type error at run time:

lib/Server.hs:115:5:
    Could not deduce (FromJSON (Upstream Colour))
      arising from a use of ‘shellOutJSON’
    from the context (MonadError String m, MonadIO m)
      bound by the type signature for
                 getColour :: (MonadError String m, MonadIO m) =>
                                      ColourName -> m Colour
      at lib/Server.hs:(109,8)-(112,18)
    In a stmt of a 'do' block: shellOutJSON cmd ["colour", "list", colour_name]
    In the expression:
      shellOutJSON cmd ["colour", "list", color_name]
    In an equation for ‘getColour’:
        getColour name
          = do { let colour_name = T.unpack $ unColourName name
                 shellOutJSON cmd ["colour", ....] }

The second line of the error tells you exactly what’s missing: the compiler can’t find a FromJSON instance for Upstream Colour.

Conclusion

By using a “wrapper” type like Upstream a I reduced the amount of code I need to write and maintain (in particular, there’s no converting back and forth between Colour and WeirdlyFormattedColour data types). The values of my various types are clearly still related and Upstream is completely agnostic to the type being wrapped – an Upstream Robot is just a Robot inside an Upstream and neither the Robot not the Upstream cares about the other part at all.

Making the wrapper parametric like this (as opposed to, for example, creating a different newtype wrapper around each of the particular types) makes i possible to write code which – like the modified shellOutJSON – doesn’t care about the what is being wrapped, just that it is wrapped.

Adding and removing the Upstream wrapper at the system boundary minimises the amount code which can incorrectly use the wrong representation and, in particular, makes it impossible for these bugs to happen in the many places I use shellOutJSON. This forces me to define wrapped FromJSON instances for all the types, even the ones that use the same JSON representation, but this is a price I’m willing to pay for an interface that makes a class of errors impossible.

Using this approach in my current project made the code shorter, simpler (in terms of number of data types and functions defined), fixed two “wrong format” bugs, and made it impossible to reintroduce them.

I’ll describe some of our development tooling in this post and leave discussion of the “real” systems we work on for a later post.

Building and deploying

Given we’re a Haskell shop, we’ve needed to figure out how to build, deploy, and manage systems written in Haskell. I’m still not sold on the whole containerisation mania which seems to be sweeping certain parts of the IT world (and certainly not for general purpose multi-tenancy). Nevertheless, we’re finding Docker quite useful.

We have a Docker image containing GHC and cabal configured to use the Stackage package set, with a bunch of frequently used Haskell packages already installed. This image is built automatically using a small set of scripts.

Most of the systems we build operate as services (HTTP servers, agents on message queue, etc.) and we “package” them as Docker images too. We have another set of scripts which use the Haskell image to build a cabal package, extract the artefacts, and stuff them into a new Docker image. This approach results in an image which is significantly smaller than it otherwise would be.

Both sets of scripts can be used manually but they are also used in Jenkins jobs. Like everything mentioned so far Jenkins and its builders all run in Docker too, so we also have some scripts to build Jenkins Docker images.

All of these Docker images are run on CoreOS servers hosted on Anchor OpenCloud, Anchor’s new OpenStack deployment. Generally, we run each service as a Docker container managed by a systemd unit with its configuration and data files (such as they are) mounted in from the host file system. Each systemd unit deletes any old container and pulls the latest image before starting the service, so upgrading an instance is easy: just restart the systemd unit.

Development tools

Various members of the team all use different operating systems (various flavours of BSD, Linux, and Mac OS X), editors (vim, emacs, Sublime Text) and have different opinions and habits about coding style, etc. To help manage improve the consistency and, hopefully, quality of our code, we developed git-vogue. git-vogue runs as a pre-commit hook (currently for git, but it can be extended) and runs a range of checks over the modified or, optionally, all files in the repository. This isn’t perfect but has helped improve our code quite considerably.