[added second part to tutorial jeremy@n-heptane.com**20080322050201] { addfile ./tutorial/SimpleSite2.lhs hunk ./tutorial/Makefile 1 -all: SimpleSite1.html +all: SimpleSite1.html SimpleSite2.html hunk ./tutorial/SimpleSite2.lhs 1 + + + +404 No More!, Part II + + + +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

+

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. +
  3. How to reuse the gallery module in a larger site
  4. +
  5. How to ensure multiple instances of gallery don't + collide.
  6. +
+ +

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 forgot 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 +> }