Parsing PGN Requires a Legal Chess Move Generator

This is the biggest problem with PGN. It uses SAN (Standard Algebraic Notation, or just “algebraic notation”) to encode chess moves in a game. However, for almost inexplicable reasons, it decided to NEVER use disambiguation files/ranks whenever possible. For example, if there are two knights that can move to e1, but one of them is pinned by an enemy piece (moving this knight would expose the king to a check and is thus an illegal move), PGN states that the move must be encoded as “Ne1″.

Thanks to this, it is impossible to know what “Ne1″ means any time you see it in PGN, unless you have a legal chess move generator to disambiguate it. The irony is that the disambiguation characters, though mentioned in the PGN standard (“8.2.3.4 Disambiguation”), do not help you disambiguate at all! If the standard just said “use Smith Notation“, the requirement of any chess knowledge would not be necessary; each recorded move would be the only possible legal move anyway, and hence, would not require the use of a full-fledged move generator, and you’d only need to keep track of where the pieces are as you move along.

Other Problems

I’ve said 99% of what I wanted to say… But! There are still other problems with PGN that annoy me and probably every single other person out there who have tried to write a program to parse PGN data:

• Two different formats: There are two PGN formats, with different stylistic requirements: “PGN Export” and “PGN Import” formats. I cannot find any reason why there should be two different formats. Just have 1 format, and call it “The PGN Standard, 2.0″!
• Stateful parsing: This is the result of the choice of SAN and disambiguation characters I mentioned above. You have to keep track of game state (where all the pieces are) in order to parse a sequence of moves. Technically speaking, even the use of Smith Notation requires that you keep track of where the pieces are, and hence, is stateful, so there is room for improvement here.
• It’s set in stone: The standard was last revised in 1994, nearly 20 years ago. Some parts of the standard remain undefined to this day.
• ASCII encoding: The world uses Unicode, and there ARE players whose names use non-English characters, such as European players, Russian players, Chinese players, etc.
• Confusion of human-friendliness and computer-friendliness: The use of SAN for the Movetext section was probably designed for easy legibility for humans. But there are other designs that make it extremely human-unfriendly, notably NAGs (Numeric Annotation Glyphs), which require that you use symbols like “$3″ for the traditional “!!” move comment.
• 80-character limit: The widespread “PGN Export” format requires you to limit every line to 80 characters. This is again due to confusion between human-friendliness and computer-friendliness. Computers would much rather have lines of text that are broken up semantically (e.g., pretty-printed XML or YAML). The case for human-friendliness is weak, because any better-than-Notepad text editor has sensible soft line-breaking. And no one encodes PGN by hand with a text editor anyway (everyone uses one of the many free PGN editing programs out there).
• 255-character limit: The “PGN Import” format requires that a line must be less than 255 characters long.
• Messy use of newlines: This character is used to break up each line to 80 or 255 characters, and is hence can be ignored when parsing. Right? Wrong. It is also used to separate two PGN games from each other. Ugh!
• Confusion between content and style: Section “3.2.1: Byte equivalence” states, “For a given PGN data file, export format representations generated by different PGN programs on the same computing system should be exactly equivalent, byte for byte.” So, this makes even whitespace significant (an extra space character will violate the standard)… even though it doesn’t play a huge role (most of the time; see “Messy use of newlines” above).
• Seven Tag Roster: There are 7 tag pairs, or key-value pairs, that are mandatory for a game for “archival storage”. Here they are:
  1. Event (the name of the tournament or match event)
  2. Site (the location of the event)
  3. Date (the starting date of the game)
  4. Round (the playing round ordinal of the game)
  5. White (the player of the white pieces)
  6. Black (the player of the black pieces)
  7. Result (the result of the game)

  And, these tags must appear in the above order (again, confusion between content and style). Technically, these tags can have empty values, so from a parsing viewpoint, having these tags with empty values is the same thing as not having these tags at all. And some of these tags are very awkward for some situations (e.g., the “Site” tag, which is geographic in nature, doesn’t really apply for the case of correspondence chess.)

• Conflict between tag pairs and Movetext: The “PlyCount” tag, for example, is redundant and does nothing but introduce errors in a PGN file. (What would you, as programmer, trust — the PlyCount tag, or the actual Movetext section? So why have the “PlyCount” tag in the first place?) The “Result” tag is also redundant, because it is supposed to be present as a “Game Termination Marker” after the Movetext section. Yet another tag that you have to check for validity…
• Clumsy date tag: The “Date” tag uses a “YYYY.MM.DD” pattern to record the date. There is no way to disambiguate the order of games with the same opponent for those 5-minute blitz games that everyone plays on the internet.

A New, Sane Standard…

If it were me, I’d do away with PGN entirely… there are just too many problems. Here are some ideas for a better chess game recording standard:

• Only require a list of moves. Do not require certain “tag pairs” such as the “Seven Tag Roster”. Make all additional data in addition to the list of actual game moves optional. Because, really, a game of chess is, essentially, a sequence of moves.
• Use of “Full Notation” for recording moves. I hereby declare my support for a new notation, called “Full Notation”: each move records what piece is moving, what piece is captured (if any), what piece a pawn was promoted to (if any), whether it is a normal move, a castling move, or an en passant capture, and the starting and destination squares of the moving piece. For castling moves, it records the starting and destination squares for both the King and Rook (with maybe aliases “O-O” and “O-O-O” for traditional orthodox castling moves), for dead-simple clarity. This removes the need for a legal move generator when parsing the moves, and also gets rid of the need for disambiguation characters entirely. It also removes any need to keep track of where the pieces are. Simplicity always wins.
• State which variant of chess we are playing, since there are many popular ones now, such as Chess960.
• Design every feature to be computer-friendly, not human-friendly. Nobody writes raw PGN by hand from scratch, so there’s no concern for “alienating” any existing PGN users.
• Maybe separate the actual game moves from the variations/commentary, to allow for easier basic parsing. The recursive structure used by PGN for defining move variations has been wildly successful (perhaps PGN’s only redeeming feature), and it makes sense to adopt this property. But I’m not sure what is the simplest way to represent the actual moves played vs. the variations/commentary.
• Be very conservative against stylistic features (e.g., PGN’s Numeric Annotation Glyphs are an excellent example of what NOT to do).
• Use XML or YAML (probably YAML). This would make it 10x easier to parse the game info, regardless of your programming-language-of-choice. This also automatically makes the standard computer-friendly.
• Use Unicode.

The above ideas would certainly make the format more “verbose” and require more disk space. But in the age of hard drives in the hundreds-of-gigabytes range, I think it makes a lot of sense to sacrifice the extra kilobytes per game to achieve simplicity. Besides, few people keep more than, say, 10,000 files in a plaintext format such as PGN. I would be delighted to see Scid, PyChess or any other free program adopt these ideas to create a new chess game recording standard… The most important feature I’d like to see would be the lack of the need for a legal move generator when parsing the moves. This alone would make the parsing 100x easier.

UPDATES:

• January 27, 2012: Don’t suggest the use of long algebraic notation. Instead, support a new notation called “Full Notation”. Also clarify some points about keeping track of game state.

NOTE: I did not do any real research before writing this post, and am making educated guesses based off the top of my head. If you are an expert at any of the stuff (astrobiology in particular) please critique this post in the comments!

Before we examine what intelligent aliens could look like, let’s first look at the most basic conditions of where life can arise, if at all. There are some very intelligent guesses as to the cosmic ingredients of life. Let us examine each ingredient in turn.

The habitable zone

All life, as far as we know, have 1 function: change one form of energy into another. There must be a steady supply of energy that can be consumed. For us, it’s the Sun, mostly, although there is also life at the ocean depths that draw energy from thermal vents (and even these vents draw their energy from the heat of the Earth’s molten core, which is also due to radioactive decay). I think it’s safe to say that there must be either a good source of steady radiation for there to be life. Now, the best way to get a steady source of radioactive energy is by orbiting a star. Stars, if of the right size, have very good lifepsans (in the order of billions of years!). But orbiting a star also has another tremendous benefit: you get to stay at a stable location in space. If there was no Sun to orbit, the Earth would be hurling across space in some random direction (and it would be frozen over rather quickly).

So, there needs to be a sun-like star. The next thing necessary for life is probably a planet-sized blob of rock with some water and an atmosphere. The planet-scale size, water, and atmosphere really go hand-in-hand and can’t exist meaningfully without the other. Let us start with water. Water is necessary for life because it is the best chemically neutral “solvent” where many different chemical reactions can take place freely. Water also has the special property of being less dense as a solid than as a liquid, which keeps it from freezing over too easily; e.g., the icebergs of the Arctic float around, and melt, when they reach warmer waters — if the ice was to simply sink the moment it froze over, such melting processes would never occur. The rocky composition of the planet is required because it provides the only way to keep the water in a stable place (what we call oceans).

Now, water itself is a very precious substance — if you are designing a planet, you’d need a way to stop water from evaporating away into space. This is because the radioactive rays from the nearby sun could slowly “boil” the water, one molecule at a time, away. So, first, you’d need some sort of protective shield around the planet to keep the water safe. The Earth uses a magnetic field to do this, and thankfully the Earth is large enough to generate a strong enough magnetic field. This is the reason why our alien world would need to be planet-sized. Also, a planet can, by virtue of its size, retain most of the water with its gravitational field; if water molecules turn into separete Hydrogen and Oxygen gas moledules, their escape into outer space could be slowed down significantly, so that such evaporation would take many millions (or billions?) of years.

So we’ve established that you need water, and a planet to keep it. What about atmosphere? Well, the atmosphere plays a very important role on Earth: it shields us from too much radiation. Yes, the Earth’s magnetic field protects us from harmful radiation, but not all of it. You still get a lot of radiation from the sun itself. For us on Earth, the ozone layer plays a big role in protecting us from direct radiation. And so it is with our hypothetical alien world: it, too would need an atmosphere of some sort (and plus, if you have large bodies of water (oceans) with an atmosphere, you could get a water cycle, so that the water gets spread across into dry land, to allow for land-dwelling organisms).

Land dweller

Sun, rocky planet, water, and atmosphere. OK. Now comes I think probably the most controversial point: the intelligent alien would be a land-based animal. To support this hypothesis, I will first get rid of the other two alternatives: flying (winged) animals and marine (ocean-dwelling) animals. First, why can’t winged animals become intelligent? My guess is that intelligence evolved from the ability to manipulate nature in accurate, reproducible ways — i.e., we could create tools with our hands, and this separated the stupid and the less-stupid. Flying animals, by the laws of physics that govern our universe, cannot be too large. In fact, the smaller the better. This is why most flying organisms are insects. Also, because nature strives for brutal simplicity whenever it can, chances are that if you find a winged creature, it will only have wings, not wings and arms. And if you only have wings, then, you won’t be able to grab things in the accurate manner required to create tools.

Well, what about marine animals? Well, the problem is basically the same as that of winged animals: you will have fins, not arms or hands, because you need to swim. Dolphins of the future could have IQs that are 5000x higher than us, but without a means to manipulate nature around them with precision instruments (e.g., hands, opposable thumb, etc.), they will be forever doomed to the same patterns of behavior as their 50 IQ ancestors. If you think about it a marine animals are just like winged animals, except that their “wind” is the water. And as for land-dwelling marine animals, I also think that this category cannot produce any intelligent life, because of the following reason: the presence of water shortens the distance between all potential predators and prey. You need as big a distance as possible between you and the predator to survive as an intelligent life form, because this is the only way you can show Nature your intelligent decision-making skills and collect enough evolution points. If sharks around a 2-mile radius can sense your presence, and there are no trees to “climb up” to to avoid them, there is very, very little time to make any decisions. This is probably why the dominant evolutionary design of underwater land dwellers (other than fish) are crustaceans, with their natural armored shells. This short predator-prey distance, or PPD, explains why dolphins cannot truly sleep like we do.

Sense organs and appearance

So that leaves us with land-dwelling animals. We can take all the clues on our own planet to make some very good guesses in this final category. My only lament is that these guesses make the hypothetical intelligent alien very, very boring (and very humanoid). First, our alien must have limbs. All land-dwelling creatures on Earth have limbs, because limbs provide the best way to move about across a hard surface inside a low-density medium (the atmosphere). Let’s throw in hands here as well, because hands, as stated above, are the best natural tools to manipulate Nature in an accurate way. Since the two-hand, two-feet design is probably the best (and simplest) way to have hands and limbs for mobility, we’ll just adopt the “two hands, two feet” design. Next, the alien must have eyes. Eyes are one of the most primitive and basic organs (many bacteria have eyes), and provide the best bang-for-the-buck in terms of the information it can gather. Light is the fastest medium of information, and also the most prevalent (the alien Sun would provide a constant stream of light, as would any moons orbiting the planet). Light allowed our own human ancestors to maximize their PPD, because they could spot predators a mile away by just their color (this is impossible to do in the ocean), and it also allowed early hunter humans to communicate with abstract symbols to each other in a manner that only they, not the prey, could understand (what we now call hand signals) to maximize their intelligent decision making skills.

Hands, feet, and eyes. OK. What about a mouth, and nose? Well the mouth is certainly mandatory: how else can you eat food? There must be at least one opening for the nutrients to enter, and so there must be at least one mouth. As for the nose, for us humans it allows us to keep a well-salivated mouth, because we can breathe through our nose (which is dry by default); if we had to always breathe through our mouths, we would have a much harder time keeping our saliva flowing and ready to eat a meal when we chanced upon it. Our alien’s mouth would also have to be salivated with some chemicals to help it chew things and swallow the fine pieces as a single whole (imagine swallowing dry leaves with zero saliva… not pleasant). The nose also functions as a primitive poison detector (e.g., rotting food); if a species had to use their mouth to test something out every time they sat down for a meal, it would die out pretty fast.

The alien will also have ears, probably. This is because they allow the organism to sense things when the eyes can’t (e.g., at night, for example). Awareness of the environment is 99.9% of the evolution game, so anything to maximize information-gathering senses helps to keep the species from going extinct.

Eyes, mouth, nose, and ears. Amazing! Our alien probably has all of these things. Now comes an interesting question: does the alien have a face like we do? Chances are, I think, yes. First, the mouth has to go at the very bottom, because this is the only way of keeping the eyes above it. Why do the eyes need to placed above the mouth? It’s because of gravity: the alien, like us, we will pick up food from the ground (a freshly killed prey animal, any collection of food from multiple sources, etc.) more than from trees or other high places. Also, water will almost always be at ground-level. Having the eyes above the mouth allows us to look out for potential threats or opportunities while we eat, simultaneously. The alien nose will also probably find a spot between the eyes and mouth, because it can’t be below the mouth or above the eyes. If below the mouth, then it would simply get in the way when eating. The nose can’t be above the eyes because of gravity again: anything expelled from the nose would hinder the eyes. So the nose goes between the eyes and mouth. As for the eyes themselves, there would be at least two of them, because having two eyes provides highly accurate depth perception, and also acts as a primitive form of “insurance”: you can lose one eye but still go on your way. Lastly, the ears are located probably on the sides, on opposite poles, because that’s the best way to capture as many sound waves as possible from different directions. Since our alien has a “face”, the ears would have to go on a different axis — the simplest would be to have the ears on the left and right, not the front (face) and back.

Our hypothetical alien probably as a face and ears like ours. But does it also have a brain behind the face, on a “head”? Could it instead have a face and brain in the “torso”, if it has one? Well, I think the alien would also have a brain inside a “head” with a face, much like ours. Why? First, keeping the bulk of the sensory organs (eyes, nose, mouth, ears) in one place is great because it allows us to protect them from harmful threats in the most efficient way. If we had our sensory organs spread apart everywhere, it would be very difficult to protect them all at once. If we just cover our heads with our hands and arms, we can protect almost all of our important sensory organs quite effectively. By covering your face alone with one hand, you protect your eyes, nose, and mouth — impressive, don’t you think? Thus, the alien will also have a head for the face. Having a head provides another benefit: it allows maximum use of the other limbs and torso — you can put them underwater, inside mud, or whatever, and it has no detrimental effect on your main senses (eyes, ears, etc.).

Now, what about the brain? Is it also inside the head of the alien? Most likely, yes. This is because the center “torso” area of the alien will already be filled up with older, more primitive organs such as a heart, digestive organs, etc. And, chances are that the brain of its more stupid ancestors would have been very close to its major sensory organs such as its eyes, for reasons of simplicity (why have extra-long neurons that go from the eyes to some far-flung brain when you can have short neurons with a brain close by?).

Conclusion

My conclusion is that intelligent aliens will look very humanoid in form. And chances are, their Earth will look very similar to ours, with an atmosphere and oceans. I don’t think this prospect is boring at all. Just imagine — they too will have a word for “water”, and “Sun” and “Earth”, as well as “face”, “eyes”, etc. The more you think about it, the more fascinating it gets.

The only unpleasant part about it is that, if we ever do meet such aliens, they will freak us out with their warped humanlike appearance. But hey, at least the freakout will go both ways, right?

So the other day, I finally got around to using the legendary QuickCheck testing library for a semi-serious project of mine. And I must say that I am very impressed with QuickCheck — it caught two subtle (but serious) errors in my core functions — in day one! I’m going to explain some basic concepts to help you get started with QuickCheck immediately; afterwards I’ll throw in a brief discussion about the Haskell Program Coverage (“Hpc”) tool, too, since it goes well with QuickCheck.

QuickCheck

The point of QuickCheck is to generate tons of random, junk values (the nastier-looking, the better) to feed into your functions. Well, they’re not really junk values, from a type system perspective, but the point is to generate lots of edge-case values that we forget to consider when writing the code. QuickCheck supports testing of pure functions as well as monadic ones (ST monad), but I’ll just focus on the pure functions because that’s what I have experience with.

So the next question is, how does QuickCheck generate random values? Well, if your function uses any of the basic types like Int, [Integer], Double, Word64, etc., QuickCheck knows how to generate the random values already. But if you use a custom type, or a unique combination of ordinary types (e.g., (Maybe Int, Maybe Int)), you have to instruct QuickCheck how to generate it. You do this by writing an instance for QuickCheck’s Arbitrary typeclass.

So let’s say my custom type is (Maybe Int, Maybe Int), and that it has a special requirement: if it is (Just a, Just b), then b must be greater than a. No problem.

newtype MPair = MPair (Maybe Int, Maybe Int)
    deriving (Show)

instance Arbitrary MPair where
    arbitrary = do
        -- First, generate a random Int.
        a <- arbitrary :: Gen Int
        -- Now generate another random Int, but such that it is greater than *a*.
        b <- suchThat (arbitrary :: Gen Int) (>a)
        -- Now choose between either (Just a), or Nothing.
        a' <- elements [Just a, Nothing]
        -- Repeat the same coin flip for *b*.
        b' <- elements [Just b, Nothing]
        -- Return the random result.
        return $ MPair (a', b')

There is a method to the madness! There are other useful combinators besides suchThat and elements, of course.

So now you’ve told QuickCheck how to generate the random values to stress-test your functions. The next step is to define the stress-tests. In the QuickCheck world, such testing functions are used to test very specific properties of your functions that must hold true no matter what you throw at it. By convention, these functions are named “prop_[function name]“.

So here’s an example, prop_isTouching, which, appropriately enough, tests the isTouching function..

prop_isTouching :: MPair -> MPair -> Bool
prop_isTouching x y =
    isTouching x' y' == isTouching y' x'
    where
    x' = fromMPair x
    y' = fromMPair y

isTouching :: (Ord a) => (Maybe a, Maybe a) -> (Maybe a, Maybe a) -> Bool
isTouching p@(pStart, pEnd) q@(qStart, qEnd)
    -- if no pair has both of its values defined, then just return False;
    -- technically this notion is incorrect, but the greater codebase behind this
    -- interprets it this way, so it's OK
    | not (isBoth p) || not (isBoth q) = False
    -- if one or both pairs are empty, then return False
    | isBlank p || isBlank q = False
    | isLeft q = inP qStart'
    | isRight q = inP qEnd'
    | isLeft p = inQ pStart'
    | isRight p = inQ pEnd'
    | otherwise = inP qStart'
        || inP qEnd'
        || inQ pStart'
        || inQ pEnd'
    where
    pStart' = fromJust pStart
    pEnd' = fromJust pEnd
    qStart' = fromJust qStart
    qEnd' = fromJust qEnd
    inP = isInside (pStart', pEnd')
    inQ = isInside (qStart', qEnd')

isLeft
    , isRight
    , isBoth
    , isBlank :: (Maybe a, Maybe a) -> Bool
isLeft (a, b) = isJust a && isNothing b
isRight (a, b) = isNothing a && isJust b
isBoth (a, b) = isJust a && isJust b
isBlank (a, b) = isNothing a && isNothing b

fromMPair :: MPair -> (Maybe Int, Maybe Int)
fromMPair (MPair a) = a

isInside :: (Ord a) => (a, a) -> a -> Bool
isInside (a, b) c = a <= c && c <= b

You might be wondering, “Hey, I thought you were going to test a function that takes (Maybe Int, Maybe Int), not (Maybe a, Maybe a)!” Well, believe me, it pays off a lot to write higher-order functions like this that work on multiple types. The fact that we can test it using Maybe Ints (a very simple type) is just one benefit. Notice how I’ve made sure to restrict isTouching‘s arguments to the Ord typeclass, since we expect the right hand value in the pair to be greater than the one on the left (if it exists). The fancy Arbitrary instance up above was not in vain.

Anyway, the isTouching function merely checks to see if one given pair “falls in” or “touches” the other pair of values. It’s a pretty mundane function, but such functions often form the backbone of the rest of your code, so it’s really important to get these 100% right. The various helper functions like isLeft, isRight, fromMPair, etc. may seem annoying, as if they get in the way of the example to test isTouching itself. But think about it: all of these auxiliary functions will, by virtue of their necessity, be tested by calling prop_isTouching! And if prop_isTouching keeps failing (and your custom type or function is too complex for a 10-minute debugging session), you can always add more prop_ functions to test these auxiliary functions in isolation. Haskell embraces small, cute functions, and so should you!

The prop_isTouching function itself is straightforward enough: it tests the “commutative” property of isTouching — that the order of the arguments does not matter.

So far so good. Now we just need to run prop_isTouching hundreds (or thousands) of times to see if it holds. QuickCheck defines some basic test running functions, for use in the IO monad. The simplest one is aptly named quickCheck. So, we can run the function above like so:

import Test.QuickCheck

import [Your testing module, where prop_isTouching resides]

main :: IO ()
main = quickCheck prop_isTouching

This will run prop_isTouching 100 times with the default testing settings. But default settings are usually not desirable (for me, I only caught errors when I “upped” the number of runs to 1000, among other things). Oh, and quickCheck will not tell you the name of the function it is testing. So here is a more useful version:

{-# LANGUAGE RecordWildCards #-}
import System.Exit
import Test.QuickCheck

import [Your testing module, where prop_isTouching resides]

-- Rigorous test arguments.
rigorous :: Args
rigorous = Args
    { replay = Nothing
    , maxSuccess = 1000 -- tests to run
    , maxDiscard = 1000 -- the number of tests that are thrown out and ignored b/c of "==>" conditions, before "giving up" and failing due to too many discarded tests
    , maxSize = 1000 -- if a prop_ function uses a list ([]) type, maxSize is the max length of the randomly generated list
    , chatty = True
    }

-- Quick test arguments.
quick :: Args
quick = Args
    { replay = Nothing
    , maxSuccess = 100
    , maxDiscard = 100
    , maxSize = 100
    , chatty = True
    }

runTests :: [String] -> IO ()
runTests as = case as of
    [] -> runTests' quick
    a -> case head a of
        "1" -> runTests' quick
        "2" -> runTests' rigorous
        _ -> runTests' quick
    where
    runTests' :: Args -> IO ()
    runTests' testArgs = do
        -- if all of your prop_ functions are of the same type, you can put
        -- them in a list and use mapM_ instead
        f prop_isTouching "prop_isTouching"
        f prop_someOtherFunc1 "someOtherFunc1"
        f prop_someOtherFunc2 "someOtherFunc2"
        f prop_someOtherFunc3 "someOtherFunc3"
        f prop_someOtherFunc4 "someOtherFunc4"
        where
        f prop str = do
            putStrLn str
            quitOnFail =<< quickCheckWithResult testArgs prop
        quitOnFail r = case r of
            -- pattern match with just two dots with RecordWildCards because I'm lazy
            Success{..} -> return ()
            _ -> exitFailure

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

If you compile the above as “test”, then running “./test 2″ will use the “rigorous” test settings. The key difference is that instead of quickCheck, we use quickCheckWithResult. With it, we can provide our choice of test settings (the Args type), and also get some feedback on what the test results were. For simplicity’s sake, we only check if the test was a complete success; if it’s anything else, we abort immediately.

Here’s a quick note about the term “shrink” that you might encounter: if QuickCheck spots a failure, it will first try to shrink the size of the random input repeatedly while maintaining the “failure” result (and QuickCheck will tell you about how many shrinks were performed). This is to help you work with reasonably small values (esp. useful if you have list arguments with hundreds of items each, like in prop_foo above).)

The careful reader would have wondered what the “==>” was about in the comments. Well, the “==>” function is called the “implication” function, and is used to throw out invalid values before running the prop_ function. It’s another way to customize the random value, sort of like how we defined a custom Arbitrary instance up above for the MPair type synonym. For example,

prop_foo :: [Int] -> [Int] -> Prop
prop_foo xs ys =
    not (null xs) ==> -- xs must not be null
    (length ys > 3) ==> -- ys must have at least 4 elements
    foo xs ys == foo ys xs

and it only gets to the “foo xs ys == bar xs ys” part if the two statements above are true. The only difference is that we have to end up with a Prop type instead of Bool, as was the case in prop_isTouching. No other part of your testing code needs to change. The advantage in using (==>) is its ease of use — you can trivially write any rare edge-case condition that you know does not conform to the spec, without bothering to write an Arbitrary instance. However, the disadvantage is that QuickCheck will waste time generating invalid inputs before it gets to the test the function in question. Because of this, you should first try to create an instance of Arbitrary before going with (==>).

Here is a version without using (==>) just for illustrative purposes:

import Data.List
import Test.QuickCheck

main = verboseCheck prop_foo

newtype Xs = Xs [Int]
    deriving (Show)
newtype Ys = Ys [Int]
    deriving (Show)

prop_foo :: Xs -> Ys -> Bool
prop_foo (Xs xs) (Ys ys) =
    foo xs ys == foo ys xs

foo :: [Int] -> [Int] -> [Int]
foo xs ys = sort $ xs ++ ys

instance Arbitrary Xs where
    arbitrary = do
    -- xs must not be null
    xs <- suchThat (arbitrary :: Gen [Int]) (not . null)
    return $ Xs xs

instance Arbitrary Ys where
    arbitrary = do
    -- ys must have at least 4 elements
    ys <- suchThat (arbitrary :: Gen [Int]) ((>3) . length)
    return $ Ys ys

That’s it! You now know enough to get started with QuickCheck today. No excuses! Make it a New Year’s resolution for 2012, if you have to!

QuickCheck has taught me to be skeptical of the “if it compiles, it is OK” Haskell attitude — it has really opened my eyes. I now want QuickCheck as a bare minimum testing setup for all of my Haskell code. No tests = poor design (Medieval II: Total War, I’m looking at you…).

QuickCheck can even be used to test C code with the Foreign Function Interface (FFI), so I’m forever tempted to go back to my other C projects and test them with QuickCheck as well (can you imagine the millions of bugs that lie hidden in C code everywhere — that could be exposed with just a little bit of Haskell knowledge and QuickCheck by the everyday developer? Suddenly, I am overcome with optimism… yet I fear that it is really pessimism underneath… hmm.)

Hpc

I said I would mention Hpc at the beginning. So, what does it do?

Simply put, Hpc tells you which codepaths were used (or not used) after running a binary executable. This is a perfect match for the binary you used for running QuickCheck tests, because during the course of its run QuickCheck will have fed tens of thousands of random values into your functions and have visited most, if not all, parts of your code. Thankfully, Hpc is included with GHC, so you already have it! Just compile your binary with the -fhpc flag. Here is the process:

1. Compile your program with -fhpc. (ghc -fhpc –make foo.hs)
2. Run your program. (./foo)
3. Your program should have generated a *.tix metadata file, as well as a .hpc folder with *.mix files for hpc to analyze.
4. Run hpc report foo for a quick plaintext report on your codepaths.
5. Run hpc markup foo to generate prettified HTML files for a more comprehensive overview.
6. Rinse and repeat. Remove the old *.tix files if you don’t want combined results.

One big caveat: make sure to delete any existing object files (*.o, *.hi) that you had earlier which were produced without the -fhpc flag! Otherwise, those portions of code will not generate hpc metadata! Alternatively, instead of deleting every *.o or *.hi file you have down your project’s folder tree, you could also pass the -fforce-recompile flag to ghc (this is the new name for the deprecated -no-recomp flag, which was used (sans explanation!) in Real World Haskell, Chapter 11).

Go forth, fellow Haskell newbies — embrace testing and code coverage analysis today!

There will always be a point where things become “unmeasurable” and “unknown.” It’s sort of like how you run out of answers to a 7-year old’s rigorous adherence to the Socratic method: if you keep asking why something is the way it is, you will eventually run out of answers. You will eventually run up against that boundary of measurable truth.

So this is the reason why I don’t understand why some people think that science can’t coexist with religion. Religion steps in exactly at the point where you cross into the unmeasurable truths. Religion answers questions like, “What happened before the Big Bang?” or “Why did the Big Bang occur?” where science cannot (at least currently). Science and religion, as far as I can see, are our eyes in the realms of measurable and unmeasurable truths, respectively. Interestingly, the study of philosophy sits right on the border, between what is measurable and not measurable, but what is still “true” in some sense of the word.

The problem with Creationism is that it tries (to comedic effect) to claim a huge chunk of science (evolution) as “unmeasurable.” It says that the human eye is so complicated yet so perfectly tuned that it must have had an intelligent creator behind its design. It says that the reason behind the existence of complex, inter-dependent organs is “unmeasurable” — unexplainable — by any scientific means. Of course, they have to blatantly ignore the mountains of evidence in support for the theory of evolution in doing so, as well as the beautiful consistency of it all.

I think the Creationists fear that the teaching of evolution will somehow destroy one’s belief in their Judeo-Christian God. But once you see that the realms of science and religion are *completely* separate, you quickly realize that such fear is unfounded. Rather, the Creationists should be concerned about the teaching of philosophy, as it asks questions that touch on religious teachings more directly.

Alas, unfortunately for the Christians, their Holy Book is embarrasingly wrong (this is the Word of God we are talking about!) on a lot of things because, like Creationism, it makes lots of utterly false statements that fall into what is measurable, into the domain of science. The story of Noah’s Ark is probably the best example. The “Earth is less than 10,000 years old” inference drawn from gathering the ages and lives of those described in the Bible is another one (it’s just plain wrong if you accept that fossils are real; and I’m not talking dinosaur bones — google “stromatolites” for some really ancient fossils). The whole thing about miracles is also problematic, because what was a miracle 2,000 years ago is not a miracle today. And for some reason all the miracles that happen today are limited to those that can be scientifically explained (but this is getting a bit off topic…).

Hmm, I guess teaching scientific knowledge in general will point to a lot of holes in the Bible, or any other Holy Book that dares to come under genuine scientific inquiry. Maybe the Bible should be rewritten. It could be that Noah’s Ark and the other accounts (some guy lived for 500+ years, IIRC) were just falsely written by some crazy guys in 100 BCE. You could just re-write the Bible and get all the good parts, like “love your enemies.” But this will never happen.

Indeed, the problem with pretty much all the world’s religions are that they have a “creation” story about how the Universe began, and end up with wonderfully confusing and comic descriptions that clash against modern scientific knowledge. I guess this is one reason why there has been an increasing rise in Atheism recently — the traditional religions have too many flaws!

Me, I just follow 1 simple code: “do good stuff, and don’t do bad stuff.” Simple, direct, and always correct. Plus, seeing the world this way, the vast majority of people I meet are also adherents of my code, at least from judging how they treat me. I don’t care enough about atheism or agnosticism to identify myself with one or the other.

EDIT: Grammar fix and clarify the title.
EDIT January 3, 2012: Minor wording tweak.

Anyway, here is the program:

-- LICENSE: PUBLIC DOMAIN
module Main where

import Control.Monad.State
import Crypto.Random.AESCtr
import Data.Binary (decode)
import qualified Data.ByteString.Lazy as B
import Data.List (nub)
import IO
import System (getArgs)
import System.IO (hSetEcho)

keysChar, keysNum, keysPunc, keysCharNum, keysAll, keysHex :: String
keysChar = ['a'..'z'] ++ ['A'..'Z']
keysHex = ['a'..'f']
keysNum = ['0'..'9']
keysPunc = "`~!@#$%^&*()-_=+[{]}\\|;:'\",<.>/? "
keysCharNum = keysChar ++ keysNum
keysAll = keysChar ++ keysNum ++ keysPunc

giveKey ::  String -> Char -> Int -> Char
giveKey keysCustom c n = extractChar $ case c of
    'i'  -> (keysNum ++ keysHex)
    'j'  -> keysNum
    'k'  -> keysChar
    'l'  -> keysCharNum
    ';'  -> keysPunc
    'h'  -> (keysCharNum ++ keysCustom)
    '\n' -> ['\n']
    _    -> keysAll
    where
    extractChar xs = xs!!mod n (length xs)

showRandomKey :: String -> StateT AESRNG IO ()
showRandomKey keysCustom = handleKey =<< liftIO getChar
    where
    handleKey key = case key of
        '\n' -> liftIO (putChar '\n') >> showRandomKey keysCustom
        'q' -> (liftIO $ putStrLn "\nBye!") >> return ()
        _ -> mapM_ f [0..(49)::Int] >> (liftIO $ putStrLn []) >> showRandomKey keysCustom
        where
        f _ = liftIO
            . putChar
            . giveKey keysCustom key
            . (\n -> mod n (length (keysAll ++ keysCustom) - 1))
            =<< aesRandomInt

aesRandomInt :: StateT AESRNG IO Int
aesRandomInt = do
    aesState <- get
    let (bs, aesState') = genRandomBytes aesState 16
    put aesState'
    return (decode $ B.fromChunks [bs])

main :: IO ()
main = do
    hSetBuffering stdin NoBuffering -- disable buffering from STDIN
    hSetBuffering stdout NoBuffering -- disable buffering from STDOUT
    hSetEcho stdin False -- disable terminal echo
    as <- getArgs
    let as' = filter (\c -> elem c keysAll) . nub $ unwords as
    mapM_ putStrLn
        [ []
        , "poke: 'q'     quit"
        , "      'j'     number"
        , "      'k'     letter"
        , "      'l'     alphanumeric"
        , "      ';'     punctuation"
        , "      'h'     alphanumeric" ++ (if null as' then [] else " + " ++ as')
        , "      'i'     hexadecimal"
        , "      'ENTER' newline"
        , "      else    any"
        , []
        ]
    aesState <- makeSystem -- gather entropy from the system to use as the initial seed
    _ <- runStateT (showRandomKey as') aesState -- enter loop
    return ()

Yes, the CPRNG used is the Advanced Encryption Standard (AES) algorithm in counter mode. It sure beats using the default System.Random module in terms of… coolness (for the purposes of this application, the use of a CPRNG over a regular PRNG really gives no benefit). Anyway, here is a sample run:

$ poke \!@#$%
poke: 'q'     quit
      'j'     number
      'k'     letter
      'l'     alphanumeric
      ';'     punctuation
      'h'     alphanumeric + !@#$%
      'i'     hexadecimal
      'ENTER' newline
      else    any

%g@c@geisBaqK81ihYkEC5NyUrWXU2ndCKr3wHkklpjvCWF9I0
zaJ,!z{db.|~vR7,MvOnPU-5v7N;cCy'],bl/d;^s[hI}RM?j>
KfdJKVygPSOufgllMAZlEaLWHSHpDrHIcgmryETcEsx5uUWlQb
49388c0958e9c51f2f4dc06a8097eb8169f715b4fcfb3ca555

I named it “poke” because I couldn’t think of any other short, UNIX-y name.

The program takes a string as input and treats it as a special class of characters to consider when generating a password with the ‘h’ key. This way, you can fit into the requirements of legacy website code that say something like, “You may use alphanumeric characters and also ‘!’ ‘@’ ‘#’ ‘$’ and ‘%’ symbols”.

The output above is from pressing ‘h’, then SPACE, then ‘l’ and finally ‘i’. You could easily extend it to take more fine-tuned options, such as a shorter password length instead of the default 50. (Hint: use this post.)

The interesting side effect of using 50-character long, randomly generated passwords is that I myself do not know these passwords! The only thing I remember is the single password used for my GnuPG private key, used to decrypt the master password file.

In case you are curious, my complete setup regarding passwords is as follows: I store all of my passwords in plaintext in a “master” file, then encrypt it with GnuPG. I use a git repo to track this encrypted file, so that I can sanely remove/delete old passwords without worrying about how to get it back if I need it. Once in a while, I use a simple shell command, gpg2 -d mypasswords.gpg | less, to view the passwords for entry into some website (hooray for copy and paste!). If I need to update/add/delete passwords, I just decrypt the master file, then edit it, and re-encrypt it and commit the change into git (btw, I decrypt it into a RAM partition to avoid leaving any traces of the plaintext file).

The GnuPG private key used to encrypt the master file is itself encrypted with CAST5 (again using GnuPG) and tracked in git. The CAST5 encryption (with the “-c” flag) is a way to encrypt a file with symmetric encryption — i.e., you supply the same password for encryption and decryption, and plus you don’t need a GnuPG key to do it! (You wouldn’t want to encrypt it using another GnuPG key, because then you’d need to encrypt the key for that GnuPG key as well — recursion!) I constantly sync the git repo holding these important, encrypted files across all of my personal machines, thumb drives, etc., for reliability and convenience.

I could learn to use KeyPass or some other software to manage my passwords, but, I’m too lazy. I’m also too paranoid to trust anyone other than myself to handle my passwords. I also take care not to store anything *too* valuable into the passwords file, or anything I type into any file anywhere, just to play it safe.

EDIT: Hey, this is my 100th post! Congratulations to me!

-- LICENSE: PUBLIC DOMAIN
{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
module Main where

import qualified Data.ByteString.Lazy as BL
import System.Console.CmdArgs.Implicit
import System.IO
import System.Environment
import System.Exit
import System.Process
import Text.Parsec.Char hiding (upper)
import Text.Parsec.Combinator
import Text.Parsec.Prim
import Text.Parsec.String
import qualified Text.Parsec.ByteString.Lazy as PB
import qualified Text.Parsec.Token as PT
import Text.Parsec.Language (emptyDef)
import Control.Monad.Identity

data Opts = Opts
    { all_devices :: Bool
    , unmount :: Bool
    , unmount_all :: Bool
    , discover :: Bool
    , no_color :: Bool
    } deriving (Data, Typeable, Show, Eq)

progOpts :: Opts
progOpts = Opts
    { all_devices = def &= help "mount all USB devices"
    , unmount = def &= help "choose a USB device to unmount"
    , unmount_all = def &= name "U" &= help "unmount all USB devices"
    , discover = def &= help "list all mounted/unmounted USB devices"
    , no_color = def &= help "disable colors"
    }
    &= details
        [ "Notes:"
        , ""
        , "The default behavior without any options is to try to mount a USB device."
            ++ " Here, `device' means a device under the /dev directory, and in our context, is actually a file system partition."
            ++ " Many USB drives have only a single partition, in which case the term `device' means both the USB drive and the single partition it has."
        , ""
        , "Also, allowing the $USER to execute the mount and umount commands with sudo privileges (sudo visudo) will make things less clunky."
        ]

getOpts :: IO Opts
getOpts = cmdArgs $ progOpts
    &= summary (_PROGRAM_INFO ++ ", " ++ _COPYRIGHT)
    &= program _PROGRAM_NAME
    &= help _PROGRAM_DESC
    &= helpArg [explicit, name "help", name "h"]
    &= versionArg [explicit, name "version", name "v", summary _PROGRAM_INFO]

_PROGRAM_NAME, _PROGRAM_VERSION, _PROGRAM_INFO, _PROGRAM_DESC, _COPYRIGHT :: String
_PROGRAM_NAME = "usbmnt"
_PROGRAM_VERSION = "0.1.0"
_PROGRAM_INFO = _PROGRAM_NAME ++ " version " ++ _PROGRAM_VERSION
_PROGRAM_DESC = "mount/unmount USB device(s)"
_COPYRIGHT = "(C) Linus Arver 2011"

data BlockDevice = BlockDevice
    { shortname :: String
    , uuid :: UUID
    , fsys :: String
    , mountPoint :: MountPoint
    } deriving (Eq)

data MountPoint
    = MPath { path :: FilePath }
    | Swap
    | Unmounted
    | UnknownBlkidVal
    deriving (Eq)

instance Show BlockDevice where
    show BlockDevice{..} = unwords
        [ shortname
        , fsys
        , uuid
        , show mountPoint
        ]

instance Show MountPoint where
    show (MPath path) = path
    show Swap = "Swap"
    show Unmounted = "Unmounted"
    show UnknownBlkidVal = "UnknownBlkidVal"

blockdeviceDefault :: BlockDevice
blockdeviceDefault = BlockDevice
    { shortname = ""
    , uuid = ""
    , fsys = ""
    , mountPoint = MPath {path = ""}
    }

data Config = Config
    { fsyss :: [(String, String)]
    , uuids :: [(UUID, String)]
    } deriving (Eq, Show)

_ALPHANUM :: String
_ALPHANUM = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']

data Color
    = Red
    | Green
    | Yellow
    | Blue
    | CNone
    deriving (Show, Eq)

colorize :: Color -> String -> String
colorize c s = case c of
    Blue -> "\x1b[1;34m" ++ s ++ "\x1b[0m"
    Green -> "\x1b[1;32m" ++ s ++ "\x1b[0m"
    Red -> "\x1b[1;31m" ++ s ++ "\x1b[0m"
    Yellow -> "\x1b[1;33m" ++ s ++ "\x1b[0m"
    _ -> s

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering
    hSetBuffering stderr NoBuffering
    opts <- getOpts
    homeDir <- getEnv "HOME"
    errNo <- argsCheck opts homeDir
    when (errNo > 0) $ exitWith $ ExitFailure errNo
    (devs, takenPaths) <- getDevices opts
    let configLoc = homeDir ++ "/.usbmnt"
    configSrc <- BL.readFile configLoc
    (confErrNo, config) <- parseConfig configSrc configLoc
    when (confErrNo > 0) $ exitWith $ ExitFailure confErrNo
    let mountablePaths = filter (\p -> not $ elem p takenPaths) $ map (\p -> "/mnt/u" ++ show p) [(0::Int)..]
        devsKV = zip (map show [(1::Int)..]) . zip devs $ mountablePaths
    prog opts config devsKV

argsCheck :: Opts -> String -> IO Int
argsCheck Opts{..} homeDir
    | null homeDir = e "could not get environment variable $HOME" 1
    | otherwise = return 0
    where
        e :: String -> Int -> IO Int
        e str num = errMsg str >> return num

prog :: Opts -> Config -> [(String, (BlockDevice, FilePath))] -> IO ()
prog opts@Opts{..} config devsKV
    | discover = do
        putStrLn "all devices:"
        mapM_ (\(_, (d, _)) -> putStrLn $ cshow d) devsKV
    | otherwise = do
        putStrLn (if (unmount || unmount_all)
            then "USB device(s) to unmount:"
            else "USB device(s) to mount:")
        mapM_ (\(n, (d, _)) -> putStrLn $ "    " ++ n ++ ") " ++ show' d) devsKV
        putStrLn ""
        mountMenu opts config devsKV
    where
        cshow :: BlockDevice -> String
        cshow b@BlockDevice{..}
            | no_color = show b
            | otherwise = case mountPoint of
                Unmounted -> colorize Green $ show b
                MPath _ -> if not $ null $ getUSBMountPath b
                    then colorize Blue $ show b
                    else show b
                _ -> show b
        show' :: BlockDevice -> String
        show' = if not (unmount || unmount_all)
            then show
            else unwords . init . words . show

mountMenu :: Opts -> Config -> [(String, (BlockDevice, FilePath))] -> IO ()
mountMenu Opts{..} config devsKV
    | unmount = if length devsKV == 1
        then do
            putStrLn "only 1 USB device to unmount"
            tryMount False config (snd . head $ devsKV) >>= exitWith
        else chooseDev prompt devsKV (tryMount False config)
    | unmount_all = do
        putStrLn "unmounting all USB devices..."
        mapM_ (tryMount False config) (map snd devsKV)
        return ()
    | all_devices = do
        putStrLn "mounting all USB devices..."
        mapM_ (tryMount True config) (map snd devsKV)
        return ()
    | length devsKV == 1 = do
        putStrLn "only 1 USB device to mount"
        tryMount True config (snd . head $ devsKV) >>= exitWith
    | otherwise = chooseDev prompt devsKV (tryMount True config)
    where
        prompt :: String
        prompt = if (unmount || unmount_all)
            then "choose USB device to unmount (q to exit)"
            else "choose USB device to mount (q to exit)"

chooseDev :: String -> [(String, (BlockDevice, FilePath))] -> ((BlockDevice, FilePath) -> IO ExitCode) -> IO ()
chooseDev prompt devsKV func = do
    putStrLn prompt
    key <- getLine
    case lookup key devsKV of
        Just dev -> func dev >>= exitWith
        _ -> case key of
            "q" -> return ()
            _ -> chooseDev prompt devsKV func

tryMount :: Bool -> Config -> (BlockDevice, FilePath) -> IO ExitCode
tryMount mount config@Config{..} (bd@BlockDevice{..}, mp)
    | (null margs) = do
        errMsg $ "UUID " ++ squote uuid ++ " was not found in config file"
        errMsg $ "filesystem " ++ squote fsys ++ " was also not found in config file"
        errMsg $ "supported file systems: " ++ (unwords $ map fst fsyss)
        exitWith (ExitFailure 1)
    | otherwise = do
    when mount $ do
        if (null $ mountArgsUUID config uuid)
            then putStrLn $ "filesystem " ++ squote fsys ++ " found in config file"
            else putStrLn $ "UUID " ++ squote uuid ++ " found in config file"
        putStrLn $ "using these arguments: " ++ squote margs
    putStr $ (if mount then "" else "un")
        ++ "mounting "
        ++ shortname
        ++ " (" ++ fsys ++ ") "
        ++ (if mount then "to " ++ mp else "from " ++ show mountPoint)
        ++ ".."
    (_, _, _, p) <- createProcess $ cmd margs shortname
    exitStatus <- waitForProcess p
    if (exitStatus == ExitSuccess)
        then do
            putStrLn "OK"
            return ExitSuccess
        else do
            putStr "FAILED\n"
            errMsg $ (if mount
                then "mount error (perhaps " ++ squote mp ++ " does not exist)"
                else "unmount error")
            return (ExitFailure 1)
    where
        margs = mountArgs config bd
        cmd arguments devPath = CreateProcess
            { cmdspec = ShellCommand (if mount
                then "sudo mount -t " ++ arguments ++ " " ++ devPath ++ " " ++ mp ++ " &>/dev/null"
                else "sudo umount " ++ show mountPoint)
            , cwd = Nothing
            , env = Nothing
            , std_in = CreatePipe
            , std_out = CreatePipe
            , std_err = Inherit
            , close_fds = False
            }

mountArgs :: Config -> BlockDevice -> String
mountArgs Config{..} BlockDevice{..} = case lookup uuid uuids of
    Just a -> a
    _ -> case lookup fsys fsyss of
        Just a -> a
        _ -> []

mountArgsUUID :: Config -> UUID -> String
mountArgsUUID Config{..} uuid' = case lookup uuid' uuids of
    Just a -> a
    _ -> []

getDevices :: Opts -> IO ([BlockDevice], [String])
getDevices Opts{..} = do
    (_, sout, _, p) <- createProcess cmdBlkid
    devs <- case sout of
        Just h -> hGetContents h
        Nothing -> return []
    _ <- waitForProcess p
    let devs' = (map (unwords . words)) . drop 2 . lines $ devs
    devs'' <- mapM parseBlkid devs'
    let toMount = filter (\BlockDevice{..} -> mountPoint == Unmounted) devs''
        toUnmount = filter (\dev -> not $ null $ getUSBMountPath dev) devs''
        takenPaths = filter (not . null) . map getUSBMountPath $ devs''
    when (not discover && null toMount && (not (unmount || unmount_all))) $ do
        errMsg $ "cannot find USB devices to mount"
        exitWith (ExitFailure 1)
    when (not discover && null toUnmount && (unmount || unmount_all)) $ do
        errMsg $ "cannot find USB devices to unmount"
        exitWith (ExitFailure 1)
    return $ formatDevs devs'' toMount toUnmount takenPaths
    where
        formatDevs :: [BlockDevice] -> [BlockDevice] -> [BlockDevice] -> [String] -> ([BlockDevice], [String])
        formatDevs ds m um takenPaths
            | discover = (ds, takenPaths)
            | unmount || unmount_all = (um, takenPaths)
            | otherwise = (m, takenPaths)
        cmdBlkid = CreateProcess
            { cmdspec = ShellCommand ("sudo blkid -o list")
            , cwd = Nothing
            , env = Nothing
            , std_in = CreatePipe
            , std_out = CreatePipe
            , std_err = Inherit
            , close_fds = False
            }

getUSBMountPath :: BlockDevice -> String
getUSBMountPath BlockDevice{..} = case mountPoint of
    MPath str -> if take 6 str == "/mnt/u" && (all (\c -> elem c ['0'..'9']) (drop 6 str))
        then str
        else ""
    _ -> ""

errMsg :: String -> IO ()
errMsg msg = hPutStrLn stderr $ "error: " ++ msg

squote :: String -> String
squote s = "`" ++ s ++ "'"

-- Parsing

-- for parsing the computer-generated output of `sudo blkid -o list'
parserIdentifier :: Parser String
parserIdentifier = many1 $ oneOf $ _ALPHANUM ++ "/-_"

parserWhitespace :: Parser String
parserWhitespace = many1 $ oneOf " \t\n\r"

parserMP :: Parser MountPoint
parserMP =
    try ( do
        a <- oneOf "<("
        b <- manyTill anyChar (lookAhead $ (oneOf ">)"))
        _ <- oneOf ">)"
        let mp = case a of
                '<' -> Swap
                '(' -> case b of
                    "not mounted" -> Unmounted
                    _ -> UnknownBlkidVal
                _ -> UnknownBlkidVal
        return mp
        )
    <|> (parserIdentifier >>= (\s -> return MPath {path = s}))
    <?> "blkid's mount point description"

blkidParser :: Parser BlockDevice
blkidParser =
    try ( do
        sname <- parserIdentifier
        _ <- parserWhitespace
        fs <- parserIdentifier
        _ <- parserWhitespace
        _ <- parserIdentifier -- leave out the "label" column, even if it exists
        _ <- parserWhitespace
        mp <- parserMP
        _ <- parserWhitespace
        uid <- parserIdentifier
        eof
        return BlockDevice
           { shortname = sname
           , uuid = uid
           , fsys = fs
           , mountPoint = mp
           }
        )
    <|>
    do  sname <- parserIdentifier
        _ <- parserWhitespace
        fs <- parserIdentifier
        _ <- parserWhitespace
        mp <- parserMP
        _ <- parserWhitespace
        uid <- parserIdentifier
        eof
        return BlockDevice
            { shortname = sname
            , uuid = uid
            , fsys = fs
            , mountPoint = mp
            }
    <?> "5 or 4 fields to parse"

parseBlkid :: String -> IO BlockDevice
parseBlkid src =
    case parse blkidParser "output of `sudo blkid -o list'" src of
        Left parseError -> errMsg (show parseError) >> return blockdeviceDefault
        Right result -> return result

-- we use a LanguageDef so that we can get whitespace/newline parsing for FREE
-- in our .usbmnt file
configDef :: PT.GenLanguageDef BL.ByteString () Identity
configDef = emptyDef
    { PT.commentStart   = ""
    , PT.commentEnd     = ""
    , PT.commentLine    = "#"
    , PT.nestedComments = False
    -- the identStart/identLetter define what a UUID will look like (a
    -- dash-separated hex number)
    , PT.identStart     = oneOf $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']
    , PT.identLetter    = oneOf $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F'] ++ "-"
    , PT.opStart        = char '.'
    , PT.opLetter       = char '.'
    , PT.reservedOpNames= []
    , PT.reservedNames  = []
    , PT.caseSensitive  = True
    }

-- we call makeTokenParser def and pick out just those we need
lexer :: PT.GenTokenParser BL.ByteString () Identity
lexer = PT.makeTokenParser configDef

p_identifier :: ParsecT BL.ByteString () Identity String
p_identifier = PT.identifier lexer
p_stringLiteral :: ParsecT BL.ByteString () Identity String
p_stringLiteral = PT.stringLiteral lexer
p_whiteSpace :: ParsecT BL.ByteString () Identity ()
p_whiteSpace = PT.whiteSpace lexer
p_braces :: ParsecT BL.ByteString () Identity a -> ParsecT BL.ByteString () Identity a
p_braces = PT.braces lexer
p_commaSep :: ParsecT BL.ByteString () Identity a -> ParsecT BL.ByteString () Identity [a]
p_commaSep = PT.commaSep lexer
p_symbol :: String -> ParsecT BL.ByteString () Identity String
p_symbol = PT.symbol lexer

type UUID = String

assocParser :: PB.Parser String -> PB.Parser (UUID, String)
assocParser keyParser = do
    key <- keyParser
    _ <- many $ oneOf " \t"
    _ <- string "="
    _ <- many $ oneOf " \t"
    mountOpts <- p_stringLiteral
    return (key, mountOpts)
    <?> "a key-value association"

hashParser :: String -> PB.Parser String -> PB.Parser [(String, String)]
hashParser hashName keyParser = do
    _ <- p_symbol hashName
    _ <- p_symbol "="
    a <- p_braces (p_commaSep $ assocParser keyParser)
    return a
    <?> "a " ++ hashName ++ " curly brace block"

configParser :: PB.Parser Config
configParser = do
    p_whiteSpace -- take care of leading whitespace/comments as defined by configDef
    -- parse FSYS_HASH first
    fsyss' <- hashParser "FSYS_HASH" (many1 alphaNum)
    p_whiteSpace
    -- now parse UUID_HASH
    uuids' <- hashParser "UUID_HASH" (p_identifier)
    eof
    return $ Config {fsyss = fsyss', uuids = uuids'}
    <?> "config with FSYS_HASH and UUID_HASH blocks"

parseConfig :: BL.ByteString -> String -> IO (Int, Config)
parseConfig src loc =
    case parse configParser ("config file at " ++ squote loc) src of
        Left parseError -> errMsg (show parseError) >> return (1, Config [] [])
        Right result -> return (0, result)

And here is the diff:

--- usbmnt.hsold	2011-11-09 11:43:02.871554967 -0800
+++ usbmnt.hsnew	2011-11-09 11:43:09.761453413 -0800
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
 module Main where
 
+import qualified Data.ByteString.Lazy as BL
 import System.Console.CmdArgs.Implicit
 import System.IO
 import System.Environment
@@ -11,6 +12,7 @@
 import Text.Parsec.Combinator
 import Text.Parsec.Prim
 import Text.Parsec.String
+import qualified Text.Parsec.ByteString.Lazy as PB
 import qualified Text.Parsec.Token as PT
 import Text.Parsec.Language (emptyDef)
 import Control.Monad.Identity
@@ -126,7 +128,7 @@
     when (errNo > 0) $ exitWith $ ExitFailure errNo
     (devs, takenPaths) <- getDevices opts
     let configLoc = homeDir ++ "/.usbmnt"
-    configSrc <- readFile configLoc
+    configSrc <- BL.readFile configLoc
     (confErrNo, config) <- parseConfig configSrc configLoc
     when (confErrNo > 0) $ exitWith $ ExitFailure confErrNo
     let mountablePaths = filter (\p -> not $ elem p takenPaths) $ map (\p -> "/mnt/u" ++ show p) [(0::Int)..]
@@ -379,7 +381,7 @@
 
 -- we use a LanguageDef so that we can get whitespace/newline parsing for FREE
 -- in our .usbmnt file
-configDef :: PT.LanguageDef st
+configDef :: PT.GenLanguageDef BL.ByteString () Identity
 configDef = emptyDef
     { PT.commentStart   = ""
     , PT.commentEnd     = ""
@@ -397,25 +399,25 @@
     }
 
 -- we call makeTokenParser def and pick out just those we need
-lexer :: PT.TokenParser ()
+lexer :: PT.GenTokenParser BL.ByteString () Identity
 lexer = PT.makeTokenParser configDef
 
-p_identifier :: ParsecT String () Identity String
+p_identifier :: ParsecT BL.ByteString () Identity String
 p_identifier = PT.identifier lexer
-p_stringLiteral :: ParsecT String () Identity String
+p_stringLiteral :: ParsecT BL.ByteString () Identity String
 p_stringLiteral = PT.stringLiteral lexer
-p_whiteSpace :: ParsecT String () Identity ()
+p_whiteSpace :: ParsecT BL.ByteString () Identity ()
 p_whiteSpace = PT.whiteSpace lexer
-p_braces :: ParsecT String () Identity a -> ParsecT String () Identity a
+p_braces :: ParsecT BL.ByteString () Identity a -> ParsecT BL.ByteString () Identity a
 p_braces = PT.braces lexer
-p_commaSep :: ParsecT String () Identity a -> ParsecT String () Identity [a]
+p_commaSep :: ParsecT BL.ByteString () Identity a -> ParsecT BL.ByteString () Identity [a]
 p_commaSep = PT.commaSep lexer
-p_symbol :: String -> ParsecT String () Identity String
+p_symbol :: String -> ParsecT BL.ByteString () Identity String
 p_symbol = PT.symbol lexer
 
 type UUID = String
 
-assocParser :: Parser String -> Parser (UUID, String)
+assocParser :: PB.Parser String -> PB.Parser (UUID, String)
 assocParser keyParser = do
     key <- keyParser
     _ <- many $ oneOf " \t"
@@ -425,7 +427,7 @@
     return (key, mountOpts)
     <?> "a key-value association"
 
-hashParser :: String -> Parser String -> Parser [(String, String)]
+hashParser :: String -> PB.Parser String -> PB.Parser [(String, String)]
 hashParser hashName keyParser = do
     _ <- p_symbol hashName
     _ <- p_symbol "="
@@ -433,7 +435,7 @@
     return a
     <?> "a " ++ hashName ++ " curly brace block"
 
-configParser :: Parser Config
+configParser :: PB.Parser Config
 configParser = do
     p_whiteSpace -- take care of leading whitespace/comments as defined by configDef
     -- parse FSYS_HASH first
@@ -445,7 +447,7 @@
     return $ Config {fsyss = fsyss', uuids = uuids'}
     <?> "config with FSYS_HASH and UUID_HASH blocks"
 
-parseConfig :: String -> String -> IO (Int, Config)
+parseConfig :: BL.ByteString -> String -> IO (Int, Config)
 parseConfig src loc =
     case parse configParser ("config file at " ++ squote loc) src of
         Left parseError -> errMsg (show parseError) >> return (1, Config [] [])

Like I said, pretty straightforward, right? The code actually only uses lazy bytestrings for parsing the configuration file. The output of the blkid command is still parsed with the old way (native Haskell strings). The only tricky part is to import the bytestring stuff (Data.ByteString.Lazy and Text.Parsec.ByteString.Lazy) as qualified imports to avoid namespace clashes. The configDef function’s type signature had to change a bit because Parsec 3.1.1 does not have a convenience type alias for LanguageDef that uses bytestrings. To be honest, I couldn’t figure out the type signatures for p_identifier, p_symbol, etc., so I had GHC do it for me. But I mean, it all took like 5-10 minutes. Easy.

So now you can parse bytestrings — lazily!

fileSystemArgs :: String -> [(String, String)]
fileSystemArgs user =
    [ ("ext2", "ext2 -o rw,relatime")
    , ("vfat", "vfat -o rw,uid=" ++ user ++ ",gid=" ++ user)
    ]

I’ve removed this code in favor of reading such options from a configuration file at runtime, as per the exercise. The code has increased to 452 lines (only about 100 more lines than before, with my verbose style), and we make use of the Text.Parsec.Token module to define a super-simple mini-language that we use in the configuration file (two curly brace blocks that define mount options). We only use bits and pieces of it, but it’s still handy because we get some super-convenient parser combinators for free — namely, braces, stringLiteral, and whiteSpace (which are actually aliased to p_braces, p_stringLiteral, and p_whiteSpace in the code). What’s more, these functions intelligently evade trailing whitespace and comment lines automatically. This is why I love Parsec!!!

So without further ado, here’s the code (PUBLIC DOMAIN):

-- LICENSE: PUBLIC DOMAIN
{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
module Main where

import System.Console.CmdArgs.Implicit
import System.IO
import System.Environment
import System.Exit
import System.Process
import Text.Parsec.Char hiding (upper)
import Text.Parsec.Combinator
import Text.Parsec.Prim
import Text.Parsec.String
import qualified Text.Parsec.Token as PT
import Text.Parsec.Language (emptyDef)
import Control.Monad.Identity

data Opts = Opts
    { all_devices :: Bool
    , unmount :: Bool
    , unmount_all :: Bool
    , discover :: Bool
    , no_color :: Bool
    } deriving (Data, Typeable, Show, Eq)

progOpts :: Opts
progOpts = Opts
    { all_devices = def &= help "mount all USB devices"
    , unmount = def &= help "choose a USB device to unmount"
    , unmount_all = def &= name "U" &= help "unmount all USB devices"
    , discover = def &= help "list all mounted/unmounted USB devices"
    , no_color = def &= help "disable colors"
    }
    &= details
        [ "Notes:"
        , ""
        , "The default behavior without any options is to try to mount a USB device."
            ++ " Here, `device' means a device under the /dev directory, and in our context, is actually a file system partition."
            ++ " Many USB drives have only a single partition, in which case the term `device' means both the USB drive and the single partition it has."
        , ""
        , "Also, allowing the $USER to execute the mount and umount commands with sudo privileges (sudo visudo) will make things less clunky."
        ]

getOpts :: IO Opts
getOpts = cmdArgs $ progOpts
    &= summary (_PROGRAM_INFO ++ ", " ++ _COPYRIGHT)
    &= program _PROGRAM_NAME
    &= help _PROGRAM_DESC
    &= helpArg [explicit, name "help", name "h"]
    &= versionArg [explicit, name "version", name "v", summary _PROGRAM_INFO]

_PROGRAM_NAME, _PROGRAM_VERSION, _PROGRAM_INFO, _PROGRAM_DESC, _COPYRIGHT :: String
_PROGRAM_NAME = "usbmnt"
_PROGRAM_VERSION = "0.1.0"
_PROGRAM_INFO = _PROGRAM_NAME ++ " version " ++ _PROGRAM_VERSION
_PROGRAM_DESC = "mount/unmount USB device(s)"
_COPYRIGHT = "PUBLIC DOMAIN"

data BlockDevice = BlockDevice
    { shortname :: String
    , uuid :: UUID
    , fsys :: String
    , mountPoint :: MountPoint
    } deriving (Eq)

data MountPoint
    = MPath { path :: FilePath }
    | Swap
    | Unmounted
    | UnknownBlkidVal
    deriving (Eq)

instance Show BlockDevice where
    show BlockDevice{..} = unwords
        [ shortname
        , fsys
        , uuid
        , show mountPoint
        ]

instance Show MountPoint where
    show (MPath path) = path
    show Swap = "Swap"
    show Unmounted = "Unmounted"
    show UnknownBlkidVal = "UnknownBlkidVal"

blockdeviceDefault :: BlockDevice
blockdeviceDefault = BlockDevice
    { shortname = ""
    , uuid = ""
    , fsys = ""
    , mountPoint = MPath {path = ""}
    }

data Config = Config
    { fsyss :: [(String, String)]
    , uuids :: [(UUID, String)]
    } deriving (Eq, Show)

_ALPHANUM :: String
_ALPHANUM = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']

data Color
    = Red
    | Green
    | Yellow
    | Blue
    | CNone
    deriving (Show, Eq)

colorize :: Color -> String -> String
colorize c s = case c of
    Blue -> "\x1b[1;34m" ++ s ++ "\x1b[0m"
    Green -> "\x1b[1;32m" ++ s ++ "\x1b[0m"
    Red -> "\x1b[1;31m" ++ s ++ "\x1b[0m"
    Yellow -> "\x1b[1;33m" ++ s ++ "\x1b[0m"
    _ -> s

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering
    hSetBuffering stderr NoBuffering
    opts <- getOpts
    homeDir <- getEnv "HOME"
    errNo <- argsCheck opts homeDir
    when (errNo > 0) $ exitWith $ ExitFailure errNo
    (devs, takenPaths) <- getDevices opts
    let configLoc = homeDir ++ "/.usbmnt"
    configSrc <- readFile configLoc
    (confErrNo, config) <- parseConfig configSrc configLoc
    when (confErrNo > 0) $ exitWith $ ExitFailure confErrNo
    let mountablePaths = filter (\p -> not $ elem p takenPaths) $ map (\p -> "/mnt/u" ++ show p) [(0::Int)..]
        devsKV = zip (map show [(1::Int)..]) . zip devs $ mountablePaths
    prog opts config devsKV

argsCheck :: Opts -> String -> IO Int
argsCheck Opts{..} homeDir
    | null homeDir = e "could not get environment variable $HOME" 1
    | otherwise = return 0
    where
        e :: String -> Int -> IO Int
        e str num = errMsg str >> return num

prog :: Opts -> Config -> [(String, (BlockDevice, FilePath))] -> IO ()
prog opts@Opts{..} config devsKV
    | discover = do
        putStrLn "all devices:"
        mapM_ (\(_, (d, _)) -> putStrLn $ cshow d) devsKV
    | otherwise = do
        putStrLn (if (unmount || unmount_all)
            then "USB device(s) to unmount:"
            else "USB device(s) to mount:")
        mapM_ (\(n, (d, _)) -> putStrLn $ "    " ++ n ++ ") " ++ show' d) devsKV
        putStrLn ""
        mountMenu opts config devsKV
    where
        cshow :: BlockDevice -> String
        cshow b@BlockDevice{..}
            | no_color = show b
            | otherwise = case mountPoint of
                Unmounted -> colorize Green $ show b
                MPath _ -> if not $ null $ getUSBMountPath b
                    then colorize Blue $ show b
                    else show b
                _ -> show b
        show' :: BlockDevice -> String
        show' = if not (unmount || unmount_all)
            then show
            else unwords . init . words . show

mountMenu :: Opts -> Config -> [(String, (BlockDevice, FilePath))] -> IO ()
mountMenu Opts{..} config devsKV
    | unmount = if length devsKV == 1
        then do
            putStrLn "only 1 USB device to unmount"
            tryMount False config (snd . head $ devsKV) >>= exitWith
        else chooseDev prompt devsKV (tryMount False config)
    | unmount_all = do
        putStrLn "unmounting all USB devices..."
        mapM_ (tryMount False config) (map snd devsKV)
        return ()
    | all_devices = do
        putStrLn "mounting all USB devices..."
        mapM_ (tryMount True config) (map snd devsKV)
        return ()
    | length devsKV == 1 = do
        putStrLn "only 1 USB device to mount"
        tryMount True config (snd . head $ devsKV) >>= exitWith
    | otherwise = chooseDev prompt devsKV (tryMount True config)
    where
        prompt :: String
        prompt = if (unmount || unmount_all)
            then "choose USB device to unmount (q to exit)"
            else "choose USB device to mount (q to exit)"

chooseDev :: String -> [(String, (BlockDevice, FilePath))] -> ((BlockDevice, FilePath) -> IO ExitCode) -> IO ()
chooseDev prompt devsKV func = do
    putStrLn prompt
    key <- getLine
    case lookup key devsKV of
        Just dev -> func dev >>= exitWith
        _ -> case key of
            "q" -> return ()
            _ -> chooseDev prompt devsKV func

tryMount :: Bool -> Config -> (BlockDevice, FilePath) -> IO ExitCode
tryMount mount config@Config{..} (bd@BlockDevice{..}, mp)
    | (null margs) = do
        errMsg $ "UUID " ++ squote uuid ++ " was not found in config file"
        errMsg $ "filesystem " ++ squote fsys ++ " was also not found in config file"
        errMsg $ "supported file systems: " ++ (unwords $ map fst fsyss)
        exitWith (ExitFailure 1)
    | otherwise = do
    when mount $ do
        if (null $ mountArgsUUID config uuid)
            then putStrLn $ "filesystem " ++ squote fsys ++ " found in config file"
            else putStrLn $ "UUID " ++ squote uuid ++ " found in config file"
        putStrLn $ "using these arguments: " ++ squote margs
    putStr $ (if mount then "" else "un")
        ++ "mounting "
        ++ shortname
        ++ " (" ++ fsys ++ ") "
        ++ (if mount then "to " ++ mp else "from " ++ show mountPoint)
        ++ ".."
    (_, _, _, p) <- createProcess $ cmd margs shortname
    exitStatus <- waitForProcess p
    if (exitStatus == ExitSuccess)
        then do
            putStrLn "OK"
            return ExitSuccess
        else do
            putStr "FAILED\n"
            errMsg $ (if mount
                then "mount error (perhaps " ++ squote mp ++ " does not exist)"
                else "unmount error")
            return (ExitFailure 1)
    where
        margs = mountArgs config bd
        cmd arguments devPath = CreateProcess
            { cmdspec = ShellCommand (if mount
                then "sudo mount -t " ++ arguments ++ " " ++ devPath ++ " " ++ mp ++ " &>/dev/null"
                else "sudo umount " ++ show mountPoint)
            , cwd = Nothing
            , env = Nothing
            , std_in = CreatePipe
            , std_out = CreatePipe
            , std_err = Inherit
            , close_fds = False
            }

mountArgs :: Config -> BlockDevice -> String
mountArgs Config{..} BlockDevice{..} = case lookup uuid uuids of
    Just a -> a
    _ -> case lookup fsys fsyss of
        Just a -> a
        _ -> []

mountArgsUUID :: Config -> UUID -> String
mountArgsUUID Config{..} uuid' = case lookup uuid' uuids of
    Just a -> a
    _ -> []

getDevices :: Opts -> IO ([BlockDevice], [String])
getDevices Opts{..} = do
    (_, sout, _, p) <- createProcess cmdBlkid
    devs <- case sout of
        Just h -> hGetContents h
        Nothing -> return []
    _ <- waitForProcess p
    let devs' = (map (unwords . words)) . drop 2 . lines $ devs
    devs'' <- mapM parseBlkid devs'
    let toMount = filter (\BlockDevice{..} -> mountPoint == Unmounted) devs''
        toUnmount = filter (\dev -> not $ null $ getUSBMountPath dev) devs''
        takenPaths = filter (not . null) . map getUSBMountPath $ devs''
    when (not discover && null toMount && (not (unmount || unmount_all))) $ do
        errMsg $ "cannot find USB devices to mount"
        exitWith (ExitFailure 1)
    when (not discover && null toUnmount && (unmount || unmount_all)) $ do
        errMsg $ "cannot find USB devices to unmount"
        exitWith (ExitFailure 1)
    return $ formatDevs devs'' toMount toUnmount takenPaths
    where
        formatDevs :: [BlockDevice] -> [BlockDevice] -> [BlockDevice] -> [String] -> ([BlockDevice], [String])
        formatDevs ds m um takenPaths
            | discover = (ds, takenPaths)
            | unmount || unmount_all = (um, takenPaths)
            | otherwise = (m, takenPaths)
        cmdBlkid = CreateProcess
            { cmdspec = ShellCommand ("sudo blkid -o list")
            , cwd = Nothing
            , env = Nothing
            , std_in = CreatePipe
            , std_out = CreatePipe
            , std_err = Inherit
            , close_fds = False
            }

getUSBMountPath :: BlockDevice -> String
getUSBMountPath BlockDevice{..} = case mountPoint of
    MPath str -> if take 6 str == "/mnt/u" && (all (\c -> elem c ['0'..'9']) (drop 6 str))
        then str
        else ""
    _ -> ""

errMsg :: String -> IO ()
errMsg msg = hPutStrLn stderr $ "error: " ++ msg

squote :: String -> String
squote s = "`" ++ s ++ "'"

-- Parsing

-- for parsing the computer-generated output of `sudo blkid -o list'
parserIdentifier :: Parser String
parserIdentifier = many1 $ oneOf $ _ALPHANUM ++ "/-_"

parserWhitespace :: Parser String
parserWhitespace = many1 $ oneOf " \t\n\r"

parserMP :: Parser MountPoint
parserMP =
    try ( do
        a <- oneOf "<("
        b <- manyTill anyChar (lookAhead $ (oneOf ">)"))
        _ <- oneOf ">)"
        let mp = case a of
                '<' -> Swap
                '(' -> case b of
                    "not mounted" -> Unmounted
                    _ -> UnknownBlkidVal
                _ -> UnknownBlkidVal
        return mp
        )
    <|> (parserIdentifier >>= (\s -> return MPath {path = s}))
    <?> "blkid's mount point description"

blkidParser :: Parser BlockDevice
blkidParser =
    try ( do
        sname <- parserIdentifier
        _ <- parserWhitespace
        fs <- parserIdentifier
        _ <- parserWhitespace
        _ <- parserIdentifier -- leave out the "label" column, even if it exists
        _ <- parserWhitespace
        mp <- parserMP
        _ <- parserWhitespace
        uid <- parserIdentifier
        eof
        return BlockDevice
           { shortname = sname
           , uuid = uid
           , fsys = fs
           , mountPoint = mp
           }
        )
    <|>
    do  sname <- parserIdentifier
        _ <- parserWhitespace
        fs <- parserIdentifier
        _ <- parserWhitespace
        mp <- parserMP
        _ <- parserWhitespace
        uid <- parserIdentifier
        eof
        return BlockDevice
            { shortname = sname
            , uuid = uid
            , fsys = fs
            , mountPoint = mp
            }
    <?> "5 or 4 fields to parse"

parseBlkid :: String -> IO BlockDevice
parseBlkid src =
    case parse blkidParser "output of `sudo blkid -o list'" src of
        Left parseError -> errMsg (show parseError) >> return blockdeviceDefault
        Right result -> return result

-- we use a LanguageDef so that we can get whitespace/newline parsing for FREE
-- in our .usbmnt file
configDef :: PT.LanguageDef st
configDef = emptyDef
    { PT.commentStart   = ""
    , PT.commentEnd     = ""
    , PT.commentLine    = "#"
    , PT.nestedComments = False
    -- the identStart/identLetter define what a UUID will look like (a
    -- dash-separated hex number)
    , PT.identStart     = oneOf $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']
    , PT.identLetter    = oneOf $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F'] ++ "-"
    , PT.opStart        = char '.'
    , PT.opLetter       = char '.'
    , PT.reservedOpNames= []
    , PT.reservedNames  = []
    , PT.caseSensitive  = True
    }

-- we call makeTokenParser def and pick out just those we need
lexer :: PT.TokenParser ()
lexer = PT.makeTokenParser configDef

p_identifier :: ParsecT String () Identity String
p_identifier = PT.identifier lexer
p_stringLiteral :: ParsecT String () Identity String
p_stringLiteral = PT.stringLiteral lexer
p_whiteSpace :: ParsecT String () Identity ()
p_whiteSpace = PT.whiteSpace lexer
p_braces :: ParsecT String () Identity a -> ParsecT String () Identity a
p_braces = PT.braces lexer
p_commaSep :: ParsecT String () Identity a -> ParsecT String () Identity [a]
p_commaSep = PT.commaSep lexer
p_symbol :: String -> ParsecT String () Identity String
p_symbol = PT.symbol lexer

type UUID = String

assocParser :: Parser String -> Parser (UUID, String)
assocParser keyParser = do
    key <- keyParser
    _ <- many $ oneOf " \t"
    _ <- string "="
    _ <- many $ oneOf " \t"
    mountOpts <- p_stringLiteral
    return (key, mountOpts)
    <?> "a key-value association"

hashParser :: String -> Parser String -> Parser [(String, String)]
hashParser hashName keyParser = do
    _ <- p_symbol hashName
    _ <- p_symbol "="
    a <- p_braces (p_commaSep $ assocParser keyParser)
    return a
    <?> "a " ++ hashName ++ " curly brace block"

configParser :: Parser Config
configParser = do
    p_whiteSpace -- take care of leading whitespace/comments as defined by configDef
    -- parse FSYS_HASH first
    fsyss' <- hashParser "FSYS_HASH" (many1 alphaNum)
    p_whiteSpace
    -- now parse UUID_HASH
    uuids' <- hashParser "UUID_HASH" (p_identifier)
    eof
    return $ Config {fsyss = fsyss', uuids = uuids'}
    <?> "config with FSYS_HASH and UUID_HASH blocks"

parseConfig :: String -> String -> IO (Int, Config)
parseConfig src loc =
    case parse configParser ("config file at " ++ squote loc) src of
        Left parseError -> errMsg (show parseError) >> return (1, Config [] [])
        Right result -> return (0, result)

And here is the new ~/.usbmnt configuration file that it parses:

# UUID/filesystem mountoptions

# the FSYS_HASH is used as a fallback, if the detected device does not match one of the UUIDs listed above
FSYS_HASH =
    { ext2 = "ext2 -o rw,relatime"
    , vfat = "vfat -o rw,uid=$USER,gid=$USER"
    }

# UUID is pretty straightforward; use blkid to figure it out for a particular device
# as for mount options, these are passed directly into the shell (/bin/sh; see createProcess in System.Process), so you can use things like $USER

# UUID_HASH = {} # if you have no particular device-specific settings

UUID_HASH =
    { 7CBF-B36F =                             "vfat -o rw,uid=$USER,gid=$USER"    # (256 MiB) SD card
    , 9c359666-a4e6-a894-3475-e6cd53660de8 =  "ext2 -o rw,relatime"               # (2 GiB) USB 2.0 thumbdrive
    }

See how there are a bunch of comment lines starting with ‘#‘? With our configDef function which defines a language with “#” as the commentLine, our convenience functions p_whiteSpace, p_symbol, etc. all avoid comment lines automatically! Sure, it’s a trivial automation here, but you can also define multiline comments and more (which I didn’t bother to do since the configuration file format I designed is so simple). I really like how I can robustly parse comment-laden text strings with such ease!

Can you imagine doing the same thing with regular expressions? I used to use regexes for parsing things like this back when I was still a very naive programmer, and then Parsec opened up the wonderful world of parsers for me (especially all the cool convenience functions you get for FREE!). The new rule I have is: use regular expressions to strictly do search-and-replace for unchanging/uniform input (using the Text.Regex.PCRE module), and to use Parsec for everything else. There’s no excuse to put off learning how to use Parsec!

Anyway, the code I posted is a working example and I really do use it in my machines! And all you need is a POSIX system with GHC, Parsec, and CmdArgs to use it.

Next time, I’ll do the second exercise and read in and parse ByteStrings instead of native Haskell Strings — just to show you how trivial the changes are!

-- LICENSE: PUBLIC DOMAIN
{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
module Main where

import Control.Monad (when)
import System.Console.CmdArgs.Implicit
import System.IO
import System.Environment
import System.Exit
import System.Process
import Text.Parsec.Char hiding (upper)
import Text.Parsec.Combinator
import Text.Parsec.Prim
import Text.Parsec.String

data Opts = Opts
    { all_devices :: Bool
    , unmount :: Bool
    , unmount_all :: Bool
    , discover :: Bool
    , no_color :: Bool
    } deriving (Data, Typeable, Show, Eq)

progOpts :: Opts
progOpts = Opts
    { all_devices = def &= help "mount all USB devices"
    , unmount = def &= help "choose a USB device to unmount"
    , unmount_all = def &= name "U" &= help "unmount all USB devices"
    , discover = def &= help "list all mounted/unmounted USB devices"
    , no_color = def &= help "disable colors"
    }
    &= details
        [ "Notes:"
        , ""
        , "The default behavior without any options is to try to mount a USB device."
            ++ " Here, `device' means a device under the /dev directory, and in our context, is actually a file system partition."
            ++ " Many USB drives have only a single partition, in which case the term `device' means both the USB drive and the single partition it has."
        , ""
        , "Also, allowing the $USER to execute the mount and umount commands with sudo privileges (sudo visudo) will make things less clunky."
        ]

getOpts :: IO Opts
getOpts = cmdArgs $ progOpts
    &= summary (_PROGRAM_INFO ++ ", " ++ _COPYRIGHT)
    &= program _PROGRAM_NAME
    &= help _PROGRAM_DESC
    &= helpArg [explicit, name "help", name "h"]
    &= versionArg [explicit, name "version", name "v", summary _PROGRAM_INFO]

_PROGRAM_NAME, _PROGRAM_VERSION, _PROGRAM_INFO, _PROGRAM_DESC, _COPYRIGHT :: String
_PROGRAM_NAME = "usbmnt"
_PROGRAM_VERSION = "0.0.1"
_PROGRAM_INFO = _PROGRAM_NAME ++ " version " ++ _PROGRAM_VERSION
_PROGRAM_DESC = "mount/unmount USB device(s)"
_COPYRIGHT = "PUBLIC DOMAIN"

data BlockDevice = BlockDevice
    { shortname :: String
    , uuid :: String
    , fsys :: String
    , mountPoint :: MountPoint
    } deriving (Eq)

data MountPoint
    = MPath { path :: FilePath }
    | Swap
    | Unmounted
    | UnknownBlkidVal
    deriving (Eq)

instance Show BlockDevice where
    show BlockDevice{..} = unwords
        [ shortname
        , fsys
        , uuid
        , show mountPoint
        ]

instance Show MountPoint where
    show (MPath path) = path
    show Swap = "Swap"
    show Unmounted = "Unmounted"
    show UnknownBlkidVal = "UnknownBlkidVal"

blockdeviceDefault :: BlockDevice
blockdeviceDefault = BlockDevice
    { shortname = ""
    , uuid = ""
    , fsys = ""
    , mountPoint = MPath {path = ""}
    }

_ALPHANUM :: String
_ALPHANUM = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']

data Color
    = Red
    | Green
    | Yellow
    | Blue
    | CNone
    deriving (Show, Eq)

colorize :: Color -> String -> String
colorize c s = case c of
    Blue -> "\x1b[1;34m" ++ s ++ "\x1b[0m"
    Green -> "\x1b[1;32m" ++ s ++ "\x1b[0m"
    Red -> "\x1b[1;31m" ++ s ++ "\x1b[0m"
    Yellow -> "\x1b[1;33m" ++ s ++ "\x1b[0m"
    _ -> s

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering
    hSetBuffering stderr NoBuffering
    opts <- getOpts
    user <- getEnv "USER"
    errNo <- argsCheck opts user
    when (errNo > 0) $ exitWith $ ExitFailure errNo
    (devs, takenPaths) <- getDevices opts
    let mountablePaths = filter (\p -> not $ elem p takenPaths) $ map (\p -> "/mnt/u" ++ show p) [(0::Int)..]
        devsKV = zip (map show [(1::Int)..]) . zip devs $ mountablePaths
    prog opts user devsKV

argsCheck :: Opts -> String -> IO Int
argsCheck Opts{..} user
    | null user = e "could not get environment variable $USER" 1
    | otherwise = return 0
    where
        e :: String -> Int -> IO Int
        e str num = errMsg str >> return num

prog :: Opts -> String -> [(String, (BlockDevice, FilePath))] -> IO ()
prog opts@Opts{..} user devsKV
    | discover = do
        putStrLn "all devices:"
        mapM_ (\(_, (d, _)) -> putStrLn $ cshow d) devsKV
    | otherwise = do
        putStrLn (if (unmount || unmount_all)
            then "USB device(s) to unmount:"
            else "USB device(s) to mount:")
        mapM_ (\(n, (d, _)) -> putStrLn $ "    " ++ n ++ ") " ++ show' d) devsKV
        putStrLn ""
        mountMenu opts user devsKV
    where
        cshow :: BlockDevice -> String
        cshow b@BlockDevice{..}
            | no_color = show b
            | otherwise = case mountPoint of
                Unmounted -> colorize Green $ show b
                MPath _ -> if not $ null $ getUSBMountPath b
                    then colorize Blue $ show b
                    else show b
                _ -> show b
        show' :: BlockDevice -> String
        show' = if not (unmount || unmount_all)
            then show
            else unwords . init . words . show

mountMenu :: Opts -> String -> [(String, (BlockDevice, FilePath))] -> IO ()
mountMenu Opts{..} user devsKV
    | unmount = if length devsKV == 1
        then do
            putStrLn "only 1 USB device to unmount"
            tryMount False user (snd . head $ devsKV) >>= exitWith
        else chooseDev prompt user devsKV (tryMount False)
    | unmount_all = do
        putStrLn "unmounting all USB devices..."
        mapM_ (tryMount False user) (map snd devsKV)
        return ()
    | all_devices = do
        putStrLn "mounting all USB devices..."
        mapM_ (tryMount True user) (map snd devsKV)
        return ()
    | length devsKV == 1 = do
        putStrLn "only 1 USB device to mount"
        tryMount True user (snd . head $ devsKV) >>= exitWith
    | otherwise = chooseDev prompt  user devsKV (tryMount True)
    where
        prompt :: String
        prompt = if (unmount || unmount_all)
            then "choose USB device to unmount (q to exit)"
            else "choose USB device to mount (q to exit)"

chooseDev :: String -> String -> [(String, (BlockDevice, FilePath))] -> (String -> (BlockDevice, FilePath) -> IO ExitCode) -> IO ()
chooseDev prompt user devsKV func = do
    putStrLn prompt
    key <- getLine
    case lookup key devsKV of
        Just dev -> func user dev >>= exitWith
        _ -> case key of
            "q" -> return ()
            _ -> chooseDev prompt user devsKV func

tryMount :: Bool -> String -> (BlockDevice, FilePath) -> IO ExitCode
tryMount mount user (BlockDevice{..}, mp) = do
    when (null $ mountArgs fsys user) $ do
        errMsg $ "unsupported file system " ++ squote fsys ++ "\nsupported file systems: " ++ (unwords $ map fst (fileSystemArgs user))
        exitWith (ExitFailure 1)
    putStr $ (if mount then "" else "un")
        ++ "mounting "
        ++ shortname
        ++ " (" ++ fsys ++ ") "
        ++ (if mount then "to " ++ mp else "from " ++ show mountPoint)
        ++ ".."
    (_, _, _, p) <- createProcess $ cmd (mountArgs fsys user) shortname
    exitStatus <- waitForProcess p
    if (exitStatus == ExitSuccess)
        then do
            putStrLn "OK"
            return ExitSuccess
        else do
            putStr "FAILED\n"
            errMsg $ (if mount
                then "mount error (perhaps " ++ squote mp ++ " does not exist)"
                else "unmount error")
            return (ExitFailure 1)
    where
        cmd arguments devPath = CreateProcess
            { cmdspec = ShellCommand (if mount
                then "sudo mount -t " ++ arguments ++ " " ++ devPath ++ " " ++ mp ++ " &>/dev/null"
                else "sudo umount " ++ show mountPoint)
            , cwd = Nothing
            , env = Nothing
            , std_in = CreatePipe
            , std_out = CreatePipe
            , std_err = Inherit
            , close_fds = False
            }

fileSystemArgs :: String -> [(String, String)]
fileSystemArgs user =
    [ ("ext2", "ext2 -o rw,relatime")
    , ("vfat", "vfat -o rw,uid=" ++ user ++ ",gid=" ++ user)
    ]

mountArgs :: String -> String -> String
mountArgs fsys user = case lookup fsys (fileSystemArgs user) of
    Just a -> a
    _ -> []

getDevices :: Opts -> IO ([BlockDevice], [String])
getDevices Opts{..} = do
    (_, sout, _, p) <- createProcess cmdBlkid
    devs <- case sout of
        Just h -> hGetContents h
        Nothing -> return []
    _ <- waitForProcess p
    let devs' = (map (unwords . words)) . drop 2 . lines $ devs
    devs'' <- mapM parseBlkid devs'
    let toMount = filter (\BlockDevice{..} -> mountPoint == Unmounted) devs''
        toUnmount = filter (\dev -> not $ null $ getUSBMountPath dev) devs''
        takenPaths = filter (not . null) . map getUSBMountPath $ devs''
    when (not discover && null toMount && (not (unmount || unmount_all))) $ do
        errMsg $ "cannot find USB devices to mount"
        exitWith (ExitFailure 1)
    when (not discover && null toUnmount && (unmount || unmount_all)) $ do
        errMsg $ "cannot find USB devices to unmount"
        exitWith (ExitFailure 1)
    return $ formatDevs devs'' toMount toUnmount takenPaths
    where
        formatDevs :: [BlockDevice] -> [BlockDevice] -> [BlockDevice] -> [String] -> ([BlockDevice], [String])
        formatDevs ds m um takenPaths
            | discover = (ds, takenPaths)
            | unmount || unmount_all = (um, takenPaths)
            | otherwise = (m, takenPaths)
        cmdBlkid = CreateProcess
            { cmdspec = ShellCommand ("sudo blkid -o list")
            , cwd = Nothing
            , env = Nothing
            , std_in = CreatePipe
            , std_out = CreatePipe
            , std_err = Inherit
            , close_fds = False
            }

getUSBMountPath :: BlockDevice -> String
getUSBMountPath BlockDevice{..} = case mountPoint of
    MPath str -> if take 6 str == "/mnt/u" && (all (\c -> elem c ['0'..'9']) (drop 6 str))
        then str
        else ""
    _ -> ""

errMsg :: String -> IO ()
errMsg msg = hPutStrLn stderr $ "error: " ++ msg

squote :: String -> String
squote s = "`" ++ s ++ "'"

-- Parsing
parserIdentifier :: Parser String
parserIdentifier = many1 $ oneOf $ _ALPHANUM ++ "/-_"

parserWhitespace :: Parser String
parserWhitespace = many1 $ oneOf " \t\n\r"

parserMP :: Parser MountPoint
parserMP =
    try ( do
        a <- oneOf "<(" -- "(not mounted)" or "<swap>"
        b <- manyTill anyChar (lookAhead $ (oneOf ">)"))
        _ <- oneOf ">)"
        let mp = case a of
                '<' -> Swap
                '(' -> case b of
                    "not mounted" -> Unmounted
                    _ -> UnknownBlkidVal
                _ -> UnknownBlkidVal
        return mp
        )
    <|> (parserIdentifier >>= (\s -> return MPath {path = s})) -- e.g., "/mnt/blah"
    <?> "blkid's mount point description"

blkidParser :: Parser BlockDevice
blkidParser =
    try ( do
        sname <- parserIdentifier
        _ <- parserWhitespace
        fs <- parserIdentifier
        _ <- parserWhitespace
        _ <- parserIdentifier -- leave out the "label" column, even if it exists
        _ <- parserWhitespace
        mp <- parserMP
        _ <- parserWhitespace
        uid <- parserIdentifier
        eof
        return BlockDevice
           { shortname = sname
           , uuid = uid
           , fsys = fs
           , mountPoint = mp
           }
        )
    <|>
    do  sname <- parserIdentifier
        _ <- parserWhitespace
        fs <- parserIdentifier
        _ <- parserWhitespace
        mp <- parserMP
        _ <- parserWhitespace
        uid <- parserIdentifier
        eof
        return BlockDevice
            { shortname = sname
            , uuid = uid
            , fsys = fs
            , mountPoint = mp
            }
    <?> "5 or 4 fields to parse"

parseBlkid :: String -> IO BlockDevice
parseBlkid src =
    case parse blkidParser "output of `sudo blkid -o list'" src of
        Left parseError -> errMsg (show parseError) >> return blockdeviceDefault
        Right result -> return result

This example compiles with ghc –make -O2 -Wall -Werror. The only 2 dependencies are Parsec, and CmdArgs.

Looking back at it, I think it’s a great example of a real-world Haskell program out in the wild. It uses Parsec to correctly parse the output from blkid, CmdArgs for sane argument handling, and also does some system calls with the createProcess command. Coding-style-wise, it uses the simple where expression wherever possible, for maximum readability and tries to keep leading whitespace to a minimum. The code is written very verbosely, with explicit type signatures for every function, because, well, it helps me keep my sanity.

I think the code is pretty straightforward. It only supports 2 file systems: the ext2 type (recommended for Linux-only USB drives), and vfat (the FAT file system used for legacy Windows support), but this could be easily extended to support ext3, ext4, or any other file system, since it just wraps around the standard mount command.

The only tricky part is blkidParser, which tries to parse 5 fields or 4 fields. The reason behind this is because blkid -o’s output looks like this:

$ sudo blkid -o list
device       fs_type label    mount point      UUID
-----------------------------------------------------------------------------------
/dev/sda1    ntfs             /mnt/windows-xp  XXXXXXXXXXXXXXXX
/dev/sda2    ext4             /                XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX
/dev/sda3    ext4             /home            XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX
/dev/sda6    swap             <swap>           XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX
/dev/sda5    ext4             /mnt/data        XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX
/dev/sdb1    ext2             (not mounted)    XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX
/dev/sdc1    vfat             (not mounted)    XXXX-XXXX

Sometimes, the label field is empty, as in the example above. So, we will end up with just 4 fields instead of 5.

I hope this sample, working program will help newbies out (esp. you who are frustrated by Real World Haskell’s clunky Parsec examples…). And for those looking to actually use it themselves for easy USB mounting/unmounting, here are some additional notes:

• Create mount points (i.e., directories) /mnt/u0, /mnt/u1, /mnt/u2, etc. so that the mount command won’t choke.
• Use shell aliases or keyboard hotkeys to avoid typing out “usbmnt -U” every single time.
• Tweak the options passed to the mount command to suit your needs (see the fileSystemArgs function).

(1) A simple exercise would be to extend usbmnt so that it reads a very simple configuration file to detect the right user-defined options to pass to mount depending on the partition’s UUID. The only additional thing you would have to do is read a file from disk and store it as a String.

(2) An eye-opening exercises for Parsec newcomers would be to pass to the parsing functions a ByteString instead of String. (The transition to a ByteString is extremely straight-forward, and requires minimal changes.)

I will do the exercises myself later on and post them in a couple weeks at the latest.

UPDATE: December 1, 2011: Here are some convenience links for those coming in from Google for the solutions to the 2 exercises: Solution for #1 Solution for #2

Happy hacking!

EDIT: December 1, 2011: Fix typo.

To scale the bitmap itself, just do it like this:

import Graphics.UI.WX
import Graphics.UI.WXCore

scaleBitmap ... = do
    imgScaled <- imageConvertToBitmap =<< imageScale img (sz newWidth newHeight)
    -- do stuff with imgScaled; e.g., draw it somewhere with drawBitmap
    bitmapDelete imgScaled
    where
        img = image "foo.bmp"
        newWidth = 100
        newHeight = 20

The key is to load up the bitmap with the generic image function, and not the usual bitmap function. This way, you can make use of the imageScale function to scale your image, and then you can convert it back again to bitmap format with imageConvertToBitmap. Finally, when we are done with drawing this image somewhere, we free the memory used up to create the bitmap version of it, by calling bitmapDelete. A bit clunky, but simple enough. I tested it with a Windows BMP with an alpha channel and it worked quite nicely.

By the way, wxHaskell is very easy to learn — you just need to skim Daan Leijen’s paper whenever you get stuck. (Leijen also wrote the beautifully powerful Parsec library — another library I enjoyed using once I got the hang of it.)

So a few months ago, I changed all of my website passwords. I used a simple pseudorandom ASCII-only character generator to ensure the uniqueness of each one. In the process, I discovered that many websites have horrible, broken password interfaces.

This post is mainly a rant. Setting and changing passwords should never be difficult, and should be 100% transparent. We end users probably collectively wasted millions of hours with broken password interfaces, and will waste millions more until the issues below are addressed each time someone deploys a new website.

Special Characters

Many websites tell you a list of special characters that are not allowed in passwords. Sadly, this list is often incomplete. Worse still, some only accept alphanumeric passwords, but are silent as to this restriction — and to top it off, they don’t even bother to tell you why your chosen password is invalid! The gall.

It appears that the restriction against special characters is largely a matter of legacy vs. modern platforms. Newer websites like Wikipedia allow you to choose any character from a US ASCII keyboard. Many older institutions (Bank of America, for example) have very strange special character restrictions, which almost seem arbitrary (did you know that Bank of America calls passwords “passcodes”?).

What needs to be done: At a minimum, allow input of ALL characters from a US ASCII keyboard ([a-zA-Z0-9] and all punctuation characters and spaces (tabs are impossible to type into a text field in some browsers, so they can be excused)).

Password Length

This is the biggest problem. For roughly 1/2 of my website passwords, they have a maximum character limit. Some even enforce a 12-character limit (socalgas.com is one example). Some enforce a 16-character limit (bugs.freedesktop.org, login.live.com). Barnesandnoble.com has a 15-character limit (no space s allowed, alphanumeric only).

But the best part is this: many of these sites do not tell you about this limit. So, you can spend 5, 10 minutes thinking out a great mnemonic device for a fantastic password, and you’ll get hit with some “Invalid Password” error. Yet another well-meaning user slapped in the face.

Many sites are fixated on only preventing 3, 4 character passwords by implementing an interactive “password strength” meter that rejects short passwords. But they still fail to tell you that your password is too long.

EDIT: Bela pointed out in the comments another common bug: the site will happily accept your chosen password, but will truncate it to a shorter length (without telling you any warnings about it, of course).

What needs to be done: Explicitly tell the user exactly how many characters they may use, and if the password is too long, tell them about it.

Stupidity Award: access.enom.com

If you change your password at this site, be extremely careful: DO NOT choose a password that is more than 30 characters long. When I changed my password to a 50-character long password, it happily accepted it. Unfortunately, the actual log-in interface only lets you type in 30 characters long! Since access.enom.com has no contact information, you’ll have to call someone somewhere somehow to sort out this mess.

Realistic Outlook

Legacy systems are really, really hard to migrate out of. My prediction is that the stupid, broken web interfaces will continue to thrive for at least 20 years. Why? It’s because people in 2031 will still be using passwords that are around 10 characters long with mostly alphanumeric symbols. Sure, web standards will have evolved by that time, but human brains will still be the same. The steady flow of 10-character passwords by the overwhelming majority of users will ensure that legacy systems remain competitive, at least when it comes to dealing with passwords.

Hopefully, by 2111, we’ll have sane password interfaces for all websites. Perhaps it will become a web standard by then, enforced by an international e-court, or some such.