First some header stuff. > {-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} > module Main where > import Control.Concurrent > import Control.Monad.Trans > import Control.Monad.Reader > import HAppS.Server hiding (method, dir) > import Text.XHtml > import Network.URI

404 No More!, Part II

(Part I and Part III)

In the previous part, we ended with the following types:

> data OurSite > = HomePage > | MyGallery Gallery > | YourGallery Gallery > deriving (Read, Show) > data Gallery > = Thumbnails > | ShowImage Int Size > deriving (Read, Show) > data Size > = Full > | Screen > deriving (Read, Show)

The problems we faced were:

  1. How to ensure that showLink was only called using data-types that were actually handled by the site
  2. How to reuse the gallery module in a larger site
  3. How to ensure multiple instances of gallery don't collide.

The Solution

To solve the first problem, we need to restrict the types that showLink can be applied to. To solve the second two problems, we need some way to record the current context so that we can use it when we generate the Link.

The perfect tool for this job is the Reader monad (also known as the Enviroment monad):

> type Link = String > type LinkM link a = Reader (link -> Link) a

We store a function in the enviroment which can be used to turn a data type into a Link. The showLink function is now parameterized over this monad as follows:

> showLink :: link -> LinkM link Link > showLink url = > do showF <- ask > return (showF url)

Now showLink can only be called on types supported by the current environment. As a practical example, our gallery function will now looks like this:

> -- dummy implementation for didactic purposes > gallery :: String -> Gallery -> LinkM Gallery Html > gallery username Thumbnails = > do img1 <- showLink (ShowImage 1 Full) > return $ pageTemplate > ((toHtml $ "Showing " ++ username ++ "'s gallery thumbnails.") +++ > br +++ > (anchor (toHtml "image 1") ! [href img1])) > gallery username (ShowImage i s) = > return $ pageTemplate (toHtml $ "showing " ++ username ++ "'s image number " ++ > show i ++ " at " ++ show s ++ " size.") > pageTemplate :: Html -> Html > pageTemplate thebody = > ((header > (thetitle (toHtml "Simple Site"))) +++ > (body thebody))

So, now if we tried to call showLink True inside gallery we would get an error like:

/home/stepcut/n-heptane/projects/haskell/urlt/tutorial/SimpleSite2.lhs:81:26:
    Couldn't match expected type `Gallery' against inferred type `Bool'
    In the first argument of `showLink', namely `True'
    In a 'do' expression: img1 <- showLink True
    In the expression:
        do img1 <- showLink True
             return
           $ pageTemplate
               ((toHtml $ "Showing " ++ username ++ "'s gallery thumbnails.")
              +++ br +++ (anchor (toHtml "image 1") ! [href img1]))
Failed, modules loaded: none.

The LinkM monad also provides us with a convenient way to embed the gallery library into a larger site:

> nestLink :: (url2 -> url1) -> LinkM url2 a -> LinkM url1 a > nestLink b = withReader (. b)

Here is how we would use nestLink to support OurSite

> ourSite :: OurSite -> LinkM OurSite Html > ourSite HomePage = > do myGallery <- showLink $ MyGallery Thumbnails > yourGallery <- nestLink YourGallery $ showLink Thumbnails > return $ pageTemplate (toHtml "go to " +++ br +++ > (anchor (toHtml "my gallery")) ! [href myGallery ] +++ br +++ > (anchor (toHtml "your gallery")) ! [href yourGallery ] > ) > ourSite (MyGallery g) = > nestLink MyGallery $ gallery "Jeremy Shaw" g > ourSite (YourGallery g) = > nestLink YourGallery $ gallery "someone else" g

Note that in the alternative for HomePage we create the links to the galleries two different ways. But in both instances the type of the link is OurSite.

More interesting is the alternatives which match on MyGallery and YourGallery. To nest the gallery we just use nestLink MyGallery and nestLink YourGallery. The gallery library itself needs no additional adjustments.

Additionally, let's say we forgegt the nestLink in the last alternative and instead write:

ourSite (YourGallery g) =
     gallery "someone else" g

At compile time we will get an error like:

/home/stepcut/n-heptane/projects/haskell/urlt/tutorial/SimpleSite2.lhs:134:6:
    Couldn't match expected type `OurSite'
           against inferred type `Gallery'
      Expected type: Reader (OurSite -> Link) Html
      Inferred type: LinkM Gallery Html
    In the expression: gallery "someone else" g
    In the definition of `ourSite':
        ourSite (YourGallery g) = gallery "someone else" g
Failed, modules loaded: none.

Conclusion

The Good

With the addition of the LinkM monad, we have neatly addressed the goals set forth. We have leveraged the type-checker to ensure that all the internal links are associated with some code that handles them. Additionally, we can import third-party modules into a larger site, and the generate links are automatically adjusted to match the site structure. We can use the same 3rd-party module in more than one place and the links will not collide.

The Bad

The implementation presented in this part is a bit limiting, because we can not use the IO monad or other similar Monads our site function. In the next part we will make some trivial modifications to use the Reader Monad Transformer instead of the plain Reader Monad.

The Links generated by this code are very scary looking. In the next part, we would show how to make prettier looking links.

Other Notes

The type-safety of the Links is in part due to the fact that the argument to the handler function is the same as the type of link the monad is parameterized over. For example:

ourSite :: OurSite -> LinkM OurSite Html

One way to enforce this required is to code it into the type which represents our site:

> > data Site link a > = Site { handleLink :: link -> LinkM link a > , defaultPage :: link > , formatLink :: link -> Link > , parseLink :: Link -> Maybe link > } > ourSiteSpec :: Site OurSite Html > ourSiteSpec = > Site { handleLink = ourSite > , defaultPage = HomePage > , formatLink = escapeURIString isUnescapedInURI . show > , parseLink = readLink > }

Alternatively, we might choose to encode it in the LinkM type directly:

> type LinkM' link a = link -> Reader (link -> Link) a

However, I find that confusing. Consider:

> testFunc :: String -> LinkM' link link > testFunc str lnk = return lnk

The type appears to indicate that testFunc takes one argument instead of two.

Also, we can not write the type signature for nestLink using the LinkM' type synonym. For these reasons I prefer the first option.

Next

In part III, we will make some small, final adjustments to make the library more usuable for real world projects

Remaining Boilerplate Code

The remaining code just wraps the example up into a working example. > runSite :: (Show link, Read link) => Site link a -> Link -> Maybe a > runSite site linkStr = > let mLink = > case linkStr of > "" -> Just (defaultPage site) > _ -> (parseLink site) linkStr > in > case mLink of > Nothing -> Nothing > (Just lnk) -> Just $ runReader ((handleLink site) lnk) (formatLink site) > where > readLink :: (Read a) => Link -> Maybe a > readLink = readM . unEscapeString > where > readM :: (Read a) => String -> Maybe a > readM str = > case reads str of > [(a,"")] -> Just a > o -> Nothing > -- * Boilerplate code for running ourSite via HAppS. > -- Easily adaptable to Network.CGI, etc. > implURL :: [ServerPartT IO Response] > implURL = > [ withRequest $ \rq -> > let link = (concat (take 1 (rqPaths rq))) > in > do lift $ print link > return . toResponse $ runSite ourSiteSpec link > ] > main :: IO () > main = > do tid <- forkIO $ simpleHTTP nullConf implURL > putStrLn "running..." > waitForTermination > killThread tid >