From 1fabee31e4c79dcd7e09b7e68bc5d12fa61ae448 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 15 Mar 2013 08:46:27 +0200
Subject: [PATCH] Included demo

---
 demo/Main.hs       |  40 ++++++++++++
 demo/Wiki.hs       | 147 +++++++++++++++++++++++++++++++++++++++++++++
 demo/WikiRoutes.hs |  41 +++++++++++++
 3 files changed, 228 insertions(+)
 create mode 100644 demo/Main.hs
 create mode 100644 demo/Wiki.hs
 create mode 100644 demo/WikiRoutes.hs

diff --git a/demo/Main.hs b/demo/Main.hs
new file mode 100644
index 00000000..ae5d6c9f
--- /dev/null
+++ b/demo/Main.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+module Main where
+
+import           Control.Applicative ((<$>))
+import           Wiki
+import           Yesod
+
+-- A very simple App, doesn't do anything except provide the Wiki.
+data App = App
+    { appWiki :: Wiki
+    }
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+/wiki WikiR Wiki appWiki
+|]
+
+instance Yesod App
+instance YesodWiki App -- Just use the defaults
+instance RenderMessage App FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+getHomeR :: Handler Html
+getHomeR = defaultLayout
+    [whamlet|
+        <p>
+            Welcome to my test application.
+            The application is pretty boring.
+            You probably want to go to
+            <a href=@{WikiR WikiHomeR}>the wiki#
+            .
+    |]
+
+main :: IO ()
+main = do
+    app <- App <$> newWiki
+    warpDebug 3000 app
diff --git a/demo/Wiki.hs b/demo/Wiki.hs
new file mode 100644
index 00000000..a7722c74
--- /dev/null
+++ b/demo/Wiki.hs
@@ -0,0 +1,147 @@
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- | Define the dispatch for a Wiki. You should probably start off by reading
+-- WikiRoutes.
+module Wiki
+    ( module WikiRoutes
+    ) where
+
+import           Control.Applicative ((<$>))
+import           Control.Monad       (unless)
+import           Data.IORef.Lifted   (readIORef, atomicModifyIORef)
+import           Data.Map            (Map)
+import qualified Data.Map            as Map
+import           Data.Text           (Text)
+import           WikiRoutes
+import           Yesod
+
+-- | A subsite needs to be an instance of YesodSubDispatch, which states how to
+-- dispatch. By using constraints, we can make requirements of our master site.
+-- In this example, we're saying that the master site must be an instance of
+-- YesodWiki.
+instance YesodWiki master => YesodSubDispatch Wiki (HandlerT master IO) where
+    -- | This is all the TH magic for dispatch. WikiRoutes provides the
+    -- resourcesWiki value automatically, and mkYesodSubDispatch will generate
+    -- a dispatch function that will call out to the appropriate handler
+    -- functions.
+    yesodSubDispatch = $(mkYesodSubDispatch resourcesWiki)
+
+-- | Helper type synonym to be used below.
+type WikiHandler a = forall master. YesodWiki master
+                  => HandlerT Wiki (HandlerT master IO) a
+
+------------- Helper functions
+
+-- | Get all of the content in the Wiki.
+getContent :: WikiHandler (Map Texts Textarea)
+getContent = getYesod >>= readIORef . wikiContent
+
+-- | Put a single new value into the Wiki.
+putContent :: Texts -> Textarea -> WikiHandler ()
+putContent k v = do
+    refMap <- wikiContent <$> getYesod
+    atomicModifyIORef refMap $ \m -> (Map.insert k v m, ())
+
+-- | Gets the homepage, which lists all of the pages available.
+getWikiHomeR :: WikiHandler TypedContent
+getWikiHomeR = do
+    content <- getContent
+    -- We use the new selectRep/provideRep functionality to provide either an
+    -- HTML or JSON representation of the page. You could just as easily
+    -- provide YAML, plain text, RSS, or anything else.
+    selectRep $ do
+        provideRep $ do
+            -- We'll use toParent to convert Wiki routes into our master site
+            -- routes.
+            toParent <- getRouteToParent
+
+            -- Run the master site's defaultLayout to style the page.
+            lift $ defaultLayout
+                [whamlet|
+                    <p>This wiki has the following pages:
+                    <ul>
+                        $forall page <- Map.keys content
+                            <li>
+                                -- Notice the usage of toParent!
+                                <a href=@{toParent $ WikiReadR page}>#{show page}
+                |]
+        -- You provide a JSON representation just by returning a JSON value.
+        -- aeson's toJSON make it easy to convert a list of values into JSON.
+        provideRep $ return $ toJSON $ Map.keys content
+
+getWikiReadR :: Texts -> WikiHandler TypedContent
+getWikiReadR page = do
+    content <- getContent
+    selectRep $ do
+        provideRep $
+            case Map.lookup page content of
+                Nothing -> do
+                    setMessage $ "Page does not exist, please create it."
+
+                    -- We don't need to convert or lift here: we're using a
+                    -- route from our subsite, and redirect lives in our
+                    -- subsite.
+                    redirect $ WikiEditR page
+                Just t -> do
+                    toParent <- getRouteToParent
+
+                    -- Notice that we lift the canEditPage function from the
+                    -- master site.
+                    canEdit <- lift $ canEditPage page
+
+                    lift $ defaultLayout
+                        [whamlet|
+                            <article>#{t}
+                            $if canEdit
+                                <p>
+                                    <a href=@{toParent $ WikiEditR page}>Edit
+                        |]
+        provideRep $ return $ toJSON $
+            case Map.lookup page content of
+                -- Our HTML representation sends a redirect if the page isn't
+                -- found, but our JSON representation just returns a JSON value
+                -- instead.
+                Nothing -> object ["error" .= ("Page not found" :: Text)]
+                Just (Textarea t) -> object ["content" .= t]
+
+getWikiEditR :: Texts -> WikiHandler Html
+getWikiEditR page = do
+    canEdit <- lift $ canEditPage page
+    unless canEdit $ permissionDenied "You do not have permissions to edit this page."
+
+    content <- getContent
+    let form = renderTable
+             $ areq textareaField "Content" (Map.lookup page content)
+
+    -- We need to use lift here since the widget will be used below.
+    -- Practically speaking, this means that we'll be rendering form messages
+    -- using the master site's translation functions.
+    ((res, widget), enctype) <- lift $ runFormPost form
+
+    case res of
+        FormSuccess t -> do
+            putContent page t
+            setMessage "Content updated"
+            redirect $ WikiEditR page
+        _ -> do
+            toParent <- getRouteToParent
+            lift $ defaultLayout
+                [whamlet|
+                    <p>
+                        <a href=@{toParent $ WikiReadR page}>Read page
+                    <form method=post action=@{toParent $ WikiEditR page} enctype=#{enctype}>
+                        <table>
+                            ^{widget}
+                            <tr>
+                                <td colspan=2>
+                                    <button>Update page
+                |]
+
+postWikiEditR :: Texts -> WikiHandler Html
+postWikiEditR = getWikiEditR
diff --git a/demo/WikiRoutes.hs b/demo/WikiRoutes.hs
new file mode 100644
index 00000000..f22c0222
--- /dev/null
+++ b/demo/WikiRoutes.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+-- | Define our Wiki data type, routes, and the YesodWiki typeclass. Due to the
+-- GHC stage restriction, the routes must be declared in a separate module from
+-- our dispatch instance.
+module WikiRoutes where
+
+import           Control.Monad          (liftM)
+import           Control.Monad.IO.Class (MonadIO)
+import           Data.IORef             (IORef, newIORef)
+import           Data.Map               (Map, empty)
+import           Yesod
+
+-- | Simple Wiki datatype: just store a Map from Wiki path to the contents of
+-- the page.
+data Wiki = Wiki
+    { wikiContent :: IORef (Map Texts Textarea)
+    }
+
+-- | A typeclass that all master sites that want a Wiki must implement. A
+-- master must be able to render form messages, as we use yesod-forms for
+-- processing user input.
+class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where
+    -- | Write protection. By default, no protection.
+    canEditPage :: Texts -> HandlerT master IO Bool
+    canEditPage _ = return True
+
+-- | Define our routes. We'll have a homepage that lists all of the pages, a
+-- read route for reading a page, and an edit route.
+mkYesodSubData "Wiki" [parseRoutes|
+/ WikiHomeR GET
+/read/*Texts WikiReadR GET
+/edit/*Texts WikiEditR GET POST
+|]
+
+-- | A convenience function for creating an empty Wiki.
+newWiki :: MonadIO m => m Wiki
+newWiki = Wiki `liftM` liftIO (newIORef empty)