Reducing redundancy in happstack tutorial code

Question

The happstack tutorial provides the following sample:

main :: IO ()
main = simpleHTTP nullConf $ msum 
       [ do methodM GET
            ok $ "You did a GET request.\n"
       , do methodM POST
            ok $ "You did a POST request.\n"
       , dir "foo" $ do methodM GET
                        ok $ "You did a GET request on /foo.\n"
       ]

It seems that ok $ is redundant here -- is there any way of pulling that out of msum so that you don't have to write ok $ three times? I tried the following, but it doesn't even compile:

main :: IO ()
main = simpleHTTP nullConf $ ok $ msum 
       [ do methodM GET
            "You did a GET request.\n"
       , do methodM POST
            "You did a POST request.\n"
       , dir "foo" $ do methodM GET
                        "You did a GET request on /foo.\n"
       ]

Is there a correct way to do this (or even better, pulling out the entirety of ok $ "You did a " and ".\n"), or is it just not possible?

I'm still getting up to speed on how monads work in Haskell, but if the above is not possible, then can you explain from a high level why there's no reasonable way to make this work, or what would need to be changed in order to allow it to be possible? I'm just trying to wrap my head around what can and cannot be done here.

Answer 1

Not sure about the type of dir, but something like this should work:

main :: IO ()
main = simpleHTTP nullConf $ msum 
       [ do methodM GET
            return "GET request"
       , do methodM POST
            return "POST request"
       , dir "foo" $ do methodM GET
                        return "GET request on /foo"
       ] >>= ok . (\s -> "You did a " ++ s ++ ".\n")

With such short blocks, I'd be tempted to un-do them:

main :: IO ()
main = simpleHTTP nullConf $ msum 
       [ methodM GET  >> return "GET request"
       , methodM POST >> return "POST request"
       , dir "foo" $ methodM GET >> return "GET request on /foo"
       ] >>= ok . (\s -> "You did a " ++ s ++ ".\n")

Answer 2

The ok is not really redundant.

Let's look at one of the do blocks up close. We will split the first do-block out into a separate function named getPart.

getPart :: ServerPart String
getPart = do methodM GET
             ok $ "You did a GET request.\n"

So, we see clearly that we are working with the ServerPart monad. Therefore every line in the do block must have a type like ServerPart a.

Writing something like this won't work:

getPart :: ServerPart String
getPart = do methodM GET
             "You did a GET request.\n"

because the last line in that do block has the type String not the require ServerPart String. The typical way to convert a String to ServerPart String is by using return:

getPart :: ServerPart String
getPart = do methodM GET
             return "You did a GET request.\n"

Remember that return has the type:

return :: (Monad m) => a -> m a

But, of course, that is not any better than what we had before. Instead of ok we have return. There is really no way to avoid that 'boilerplate'. You need a ServerPart String not a String and that means applying a function like return or ok to do the lifting.

As you note, the "You did a " part of the message is redundant. There are several ways we could deal with that. We could have the handlers just return the part of the message that is different like this:

handlers :: ServerPart String
handlers = 
       [ do methodM GET
            ok $ "GET request"
       , do methodM POST
            ok $ "POST request"
       , dir "foo" $ do methodM GET
                        ok $ "GET request on /foo"
       ]

And then we can get that String and add the rest of the message:

main :: IO ()
main = simpleHTTP nullConf $ do msg <- handlers
                                return ("You did a " ++ msg ++ ".\n")

(This can be expressed more compactly, but I am aiming for readability here).

One problem with that solution is that it forces all those handlers to conform to the exact same mold. If we wanted to add a handler that returned a message that did not fit that pattern, we would be in trouble. Another option would be to create a simple helper function that encapsulates that pattern:

methodMsg :: Method -> String -> ServerPart String
methodMsg mthd msg = do methodM mthd
                        ok $ "You did a " ++ msg ++ ".\n"

main :: IO ()
main = simpleHTTP nullConf $ msum 
       [ methodMsg GET  "GET request"
       , methodMsg POST "POST request"
       , dir "foo" $ methodMsg GET "GET request on /foo"
       -- the bar handler does not follow the pattern
       , dir "bar" $ ok $ "let's go to the bar!"
       ]

Hope this helps!