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

404 No More!, Part III

(Part I and Part II)

In this part, we will make some minor modifications to the Link monad so that it is more usuable in real world applications. These modifications include:

  1. Make the Link monad be a monad transformer instead, so that we can mix in IO and other monads.
  2. Making the generated links a bit more user and search engine friendly.
  3. Allow the generated link to be something other than a String.

Generalized LinkT type

The first thing we do is base our code on the Reader monad transformer instead of the plain Reader monad. We also make the type of displayed link polymorphic.

> type LinkT link display m a = ReaderT (link -> display) m a

The LinkT type has for parameters:

link
Our navigation type
display
The type of a link which has been converted to a showable form
m
An arbitrary monad we wish to transform.
a
The return type

The showLink and nestLink functions are the same as before, but with a slightly different type signatures

> showLink :: (Monad m) => link -> LinkT link display m display > showLink url = > do showF <- ask > return (showF url) > nestLink :: (link2 -> link1) -> LinkT link2 display m a -> LinkT link1 display m a > nestLink b = withReaderT (. b)

Prettier Links

The links we generated before were pretty ugly. They looked something like this:

http://localhost:8000/MyGallery%20(ShowImage%201%20Full)

Instead of using read and show, we can supply fancier formating/parsing algorithms. The following two functions will generate and parsing links which look more like:

http://localhost:8000/!MyGallery/!!ShowImage/1/Full

Unfortunately, the following code is quite broken and does not play well with others. For example, if a link points to a .css file, and the .css file references image.png, the browser will try to rewrite the path replacing whatever comes after the last / with image.png. So, consider this section a work in progress. (In fact, consider everything in this series a work in progress). > type Link = String > prettyFormatLink :: Data a => a -> Link > prettyFormatLink t = > let args = gmapQ prettyFormatLink t > in encode $ > "/" ++ (replicate (length args) '!') > ++ showConstr (toConstr t) > ++ concat args > where > encode = escapeURIString isUnescapedInURI > prettyParseLink :: Data a => Link -> Maybe a > prettyParseLink str = > rewrite str > where > rewrite s = > case gread $ toParens (evalState toTree (map args (words (map toSpace (decode s)))) ) of > [(v, "")] -> Just v > _ -> Nothing > toSpace '/' = ' ' > toSpace o = o > args argStr = > let (pluses, rest) = span (== '!') argStr > in (length pluses, rest) > toTree :: State [(Int, String)] (Tree String) > toTree = > do (argCount, constr) <- next > args <- replicateM argCount toTree > return $ Node constr args > toParens (Node constr args) = > "(" ++ constr ++ (concatMap ((" " ++) . toParens) args) ++ ")" > decode = unEscapeString > next :: (MonadState [s] m) => m s > next = > do (x:xs) <- get > put xs > return x

What's Left To Do?

The current implementation only looks at the path portion of the URL. We have not considered differentiating between GET and POST requests, etc. This can be done in the site code -- but perhaps it could be explicitly annotated in the data type you create to represent your site navigation.

link forwarding/migration

The rest of the example

We can now convert our example to use the new type.

> data OurSite > = HomePage > | MyGallery Gallery > | YourGallery Gallery > deriving (Data, Typeable) > data Gallery > = Thumbnails > | ShowImage Int Size > deriving (Data, Typeable) > data Size > = Full > | Screen > deriving (Data, Typeable, Show) > -- dummy implementation for didactic purposes > gallery :: (Monad m) => String -> Gallery -> LinkT Gallery Link m 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)) > ourSite :: (Monad m) => OurSite -> LinkT OurSite Link m 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 > > data Site link url m a > = Site { handleLink :: link -> LinkT link url m a > , defaultPage :: link > , formatLink :: link -> url > , parseLink :: url -> Maybe link > } > -- runSite :: (Monad m) => Site link Link m a -> Link -> m (Maybe a) > runSite site linkStr = > let mLink = > case linkStr of > "" -> Just (defaultPage site) > _ -> (parseLink site) linkStr > in > case mLink of > Nothing -> return Nothing > (Just lnk) -> return . Just =<< runReaderT ((handleLink site) lnk) (formatLink site) > ourSiteSpec :: (Monad m) => Site OurSite Link m Html > ourSiteSpec = > Site { handleLink = ourSite > , defaultPage = HomePage > , formatLink = prettyFormatLink -- escapeURIString isUnescapedInURI . show > , parseLink = prettyParseLink -- readLink > } > -- * Boilerplate code for running ourSite via HAppS. > -- Easily adaptable to Network.CGI, etc. > implURL :: (ToMessage a) => Site link Link (WebT IO) a -> [ServerPartT IO Response] > implURL siteSpec = > [ withRequest $ \rq -> > let link = (concat (intersperse "/" (rqPaths rq))) > in > do lift $ print link > return . toResponse =<< runSite siteSpec link > ] > main :: IO () > main = > do tid <- forkIO $ simpleHTTP nullConf (implURL ourSiteSpec) > putStrLn "running..." > waitForTermination > killThread tid >