123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148 |
- {-# LANGUAGE FlexibleInstances #-}
- {-# LANGUAGE MultiParamTypeClasses #-}
- {-# LANGUAGE OverloadedStrings #-}
- {-# LANGUAGE QuasiQuotes #-}
- {-# LANGUAGE RankNTypes #-}
- {-# LANGUAGE TemplateHaskell #-}
- {-# LANGUAGE TypeFamilies #-}
- {-# OPTIONS_GHC -fno-warn-orphans #-}
- 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
- instance YesodWiki master => YesodSubDispatch Wiki (HandlerT master IO) where
-
-
-
-
- yesodSubDispatch = $(mkYesodSubDispatch resourcesWiki)
- type WikiHandler a = forall master. YesodWiki master
- => HandlerT Wiki (HandlerT master IO) a
- getContent :: WikiHandler (Map Texts Textarea)
- getContent = getYesod >>= readIORef . wikiContent
- putContent :: Texts -> Textarea -> WikiHandler ()
- putContent k v = do
- refMap <- wikiContent <$> getYesod
- atomicModifyIORef refMap $ \m -> (Map.insert k v m, ())
- getWikiHomeR :: WikiHandler TypedContent
- getWikiHomeR = do
- content <- getContent
-
-
-
- selectRep $ do
- provideRep $ do
-
-
- toParent <- getRouteToParent
-
- lift $ defaultLayout
- [whamlet|
- <p>This wiki has the following pages:
- <ul>
- $forall page <- Map.keys content
- <li>
-
- <a href=@{toParent $ WikiReadR page}>#{show page}
- |]
-
-
- 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."
-
-
-
- redirect $ WikiEditR page
- Just t -> do
- toParent <- getRouteToParent
-
-
- 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
-
-
-
- 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)
-
-
-
- ((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
|