> {-# 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 --
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:
String.> 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 -> -+ rmfile ./tutorial/SimpleSite3.html addfile ./tutorial/SimpleSite3.lhs hunk ./tutorial/SimpleSite1.lhs 21 + +
I expect that the technique shown in this series is applicable to + other problems, but I am focusing on hyperlinks, because that is what + is immediately useful to me. If you think up some other pratical + uses, let me know and I will mention them.
hunk ./tutorial/SimpleSite3.lhs 1 + + + +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:
String.LinkT typeThe 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:
linkdisplaymaThe showLink and nestLink functions are
+ the same as before, but with a slightly different type signatures
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
+
+> 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
+
+ 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.
+ +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 :: [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 +> }