[Added code for part III, but not the text. jeremy@n-heptane.com**20080323054549] { addfile ./tutorial/SimpleSite3.html hunk ./tutorial/Makefile 1 -all: SimpleSite1.html SimpleSite2.html +all: SimpleSite1.html SimpleSite2.html SimpleSite3.html hunk ./tutorial/SimpleSite1.lhs 15 + +

The core code is mind-numbingly simple -- one type signature and + two one-liner functions. In fact, it is so simple looking, it will + take me three parts to explain why it is actually somewhat cool and + useful. Some familiarity with the Reader monad is useful but not + essential.

hunk ./tutorial/SimpleSite3.html 1 - + + + +404 No More!, Part III + + + +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

+

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. +
  2. Making the generated links a bit more user and search engine friendly.
    3. +
  3. Allow the generated link to be something other than a String.
    4. +
+ +
> type LinkT link url m a = ReaderT (link -> url) m a
+
+
> type Link = String
+
+
> showLink :: (Monad m) => link -> LinkT link url m url
+> showLink url =
+>    do showF <- ask
+>       return (showF url)
+
+ +
> nestLink :: (url2 -> url1) -> LinkT url2 url m a -> LinkT url1 url m a
+> nestLink b = withReaderT (. b)
+
+ +
> 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
+>          }
+
+ +
> 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
+
+ +
> -- * Boilerplate code for running ourSite via HAppS. 
+> -- Easily adaptable to Network.CGI, etc.
+
+
> implURL :: [ServerPartT IO Response]
+> implURL =
+>     [ withRequest $ \rq ->
+>           let link = (concat (intersperse "/" (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
+>
+
}