corebot-bliki 0.1 → 0.2
raw patch · 14 files changed
+974/−1 lines, 14 files
Files
- corebot-bliki.cabal +48/−1
- src/Yesod/CoreBot/Bliki.hs +90/−0
- src/Yesod/CoreBot/Bliki/Base.hs +19/−0
- src/Yesod/CoreBot/Bliki/Cache/UpdateHTML.hs +135/−0
- src/Yesod/CoreBot/Bliki/Config.hs +57/−0
- src/Yesod/CoreBot/Bliki/DB.hs +89/−0
- src/Yesod/CoreBot/Bliki/Prelude.hs +60/−0
- src/Yesod/CoreBot/Bliki/Resources/Base.hs +54/−0
- src/Yesod/CoreBot/Bliki/Resources/Blog.hs +59/−0
- src/Yesod/CoreBot/Bliki/Resources/Data.hs +227/−0
- src/Yesod/CoreBot/Bliki/Resources/Static.hs +29/−0
- src/Yesod/CoreBot/Bliki/Resources/Wiki.hs +43/−0
- src/Yesod/CoreBot/Bliki/Store.hs +47/−0
- src/Yesod/CoreBot/Bliki/Widgets.hs +17/−0
corebot-bliki.cabal view
@@ -1,5 +1,5 @@ name: corebot-bliki-version: 0.1+version: 0.2 synopsis: A bliki written using yesod. Uses pandoc to process files stored in git. description: Also provides a sample use of the library that uses $HOME/bliki for data and serves to port 8080.@@ -10,14 +10,61 @@ license: BSD3 license-file: LICENSE homepage: http://github.com/coreyoconnor/corebot-bliki+category: yesod+maintainer: Corey O'Connor<coreyoconnor@gmail.com> source-repository head type: git location: git://github.com/coreyoconnor/corebot-bliki.git +library + hs-source-dirs: src+ exposed-modules: Yesod.CoreBot.Bliki+ Yesod.CoreBot.Bliki.Widgets+ Yesod.CoreBot.Bliki.Config+ other-modules: Yesod.CoreBot.Bliki.Store+ Yesod.CoreBot.Bliki.DB+ Yesod.CoreBot.Bliki.Resources.Blog+ Yesod.CoreBot.Bliki.Resources.Data+ Yesod.CoreBot.Bliki.Resources.Wiki+ Yesod.CoreBot.Bliki.Resources.Static+ Yesod.CoreBot.Bliki.Resources.Base+ Yesod.CoreBot.Bliki.Base+ Yesod.CoreBot.Bliki.Prelude+ Yesod.CoreBot.Bliki.Cache.UpdateHTML+ extensions: TemplateHaskell+ QuasiQuotes+ TypeFamilies+ MultiParamTypeClasses+ FlexibleInstances+ NoMonomorphismRestriction+ OverloadedStrings+ RankNTypes+ ScopedTypeVariables+ UndecidableInstances+ EmptyDataDecls+ GADTs+ FlexibleContexts+ build-depends: base >= 4.4.0 && < 5,+ aeson >= 0.3.2.11,+ blaze-builder >= 0.3.0.1,+ bytestring >= 0.9.2.0,+ containers >= 0.4.1.0,+ directory >= 1.1.0.1,+ filepath >= 1.2.0.1,+ filestore >= 0.4.0.5,+ http-types >= 0.6.7,+ monads-tf >= 0.1.0.0,+ pandoc >= 1.9,+ text >= 0.11.1.5,+ template-haskell >= 2.6.0.0,+ time >= 1.2.0.5,+ yesod >= 0.9.4.1+ executable corebot-bliki main-is: DefaultMain.hs hs-source-dirs: src+ other-modules: Paths_corebot_bliki extensions: TemplateHaskell QuasiQuotes TypeFamilies
+ src/Yesod/CoreBot/Bliki.hs view
@@ -0,0 +1,90 @@+module Yesod.CoreBot.Bliki ( mk_bliki+ , default_blog_entry+ , indirect_load+ , Bliki_(..)+ , module Yesod.CoreBot.Bliki.Config+ , module Yesod.CoreBot.Bliki.Resources.Base+ ) where++import Yesod.CoreBot.Bliki.Prelude++import Yesod.CoreBot.Bliki.Base+import Yesod.CoreBot.Bliki.Config++import Yesod.CoreBot.Bliki.Resources.Base+import qualified Yesod.CoreBot.Bliki.Resources.Blog as Blog+import qualified Yesod.CoreBot.Bliki.Resources.Data as Data+import qualified Yesod.CoreBot.Bliki.Resources.Static as Static+import qualified Yesod.CoreBot.Bliki.Resources.Wiki as Wiki++import qualified Data.Text as Text+import qualified Data.Text.Encoding++-- | Constructs a Bliki component given the config.+--+-- This is parameterised by the Yesod app. Represented by the "master" type variable. With this type+-- and the routes in Config the Bliki can coordinate between other subsites of the app. The other+-- subsites support the resources required by the bliki. +--+-- This would not need the routes in Config and the master type if a Bliki was entirely represented+-- by a single Yesod subsite. I did not find that this provided the flexibility I wanted to+-- supported both the the REST URIs for corebotllc.com and the URIs other people might want.+--+-- For an example of how a Bliki is constructed and integrated into a Yesod app see DefaultMain.hs+mk_bliki :: Yesod master+ => Config master+ -> IO ( Bliki_ master )+mk_bliki config = do+ src_data <- Data.mk_data config+ blog <- Blog.mk_blog src_data+ wiki <- Wiki.mk_wiki src_data+ return Bliki { data_res = src_data+ , blog_res = blog+ , wiki_res = wiki+ }++getMainR = do+ bliki <- getYesodSub+ defaultLayout $ do+ default_blog_entry bliki++indirect_load bliki data_R = do+ let cfg = config $ data_res bliki+ base_URL <- approot <$> ( lift getYesod )+ let wiki_node_URL = render_absolute_URL base_URL $ data_routes cfg $ EntryLatestR []+ addScript $ static_routes cfg $ FileR "jquery.min.js"+ addScript $ static_routes cfg $ FileR "indirect_load.js"+ -- XXX: the $(.blog_content) is not specific enough. Needs to be exactly the element tied to+ -- this data_R+ addHamletHead [hamlet|+<script>+ \$(document).ready( function() + {+ \$.get ( "@{data_R}"+ , function( data ) + {+ \$(".blog_content").html(data);+ process_HTML_for_wiki(data, $(".blog_content"), "#{wiki_node_URL}");+ }+ , 'html'+ );+ } );++|]++default_blog_entry bliki = do+ let cfg = config $ data_res bliki+ data_R = data_routes cfg $ LatestR+ indirect_load bliki data_R+ [whamlet|+<div .blog_content>+ Loading + <a href=@{data_R}>+ latest blog entry + \ HTML content.+|]++mkYesodSubDispatch "Bliki_ master" [] [parseRoutes|+/ MainR GET+|]+
+ src/Yesod/CoreBot/Bliki/Base.hs view
@@ -0,0 +1,19 @@+module Yesod.CoreBot.Bliki.Base where++import Yesod.CoreBot.Bliki.Prelude++import Yesod.CoreBot.Bliki.Config+import Yesod.CoreBot.Bliki.Resources.Base++data Bliki_ master = Bliki+ { data_res :: Data_ master+ , blog_res :: Blog_ master+ , wiki_res :: Wiki_ master+ }++-- | The bliki can also be used as a subsite. If so then these are the routes supported by the+-- Bliki_ subsite.+mkYesodSubData "Bliki_ master" [] [parseRoutes|+/ MainR GET+|]+
+ src/Yesod/CoreBot/Bliki/Cache/UpdateHTML.hs view
@@ -0,0 +1,135 @@+module Yesod.CoreBot.Bliki.Cache.UpdateHTML where++import Yesod.CoreBot.Bliki.Prelude++import Yesod.CoreBot.Bliki.Config+import Yesod.CoreBot.Bliki.Resources.Base+import Yesod.CoreBot.Bliki.Store+import Yesod.CoreBot.Bliki.DB++import HereDoc++import Control.Monad.Reader++import qualified Data.ByteString.Lazy as B++import Data.FileStore ( Revision(..) + , TimeRange(..)+ , Resource+ , RevisionId+ )+import qualified Data.FileStore as FileStore++import qualified Data.Text as Text++import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL++import Text.Pandoc +import Text.Pandoc.Shared++import System.Directory++pandoc_write_options :: ConfigM master m+ => Maybe Bloggable + -> m WriterOptions+pandoc_write_options mprev_update = do+ extra_vars <- case mprev_update of+ Nothing -> return []+ Just (UpdateBloggable _ prev_rev_ID _) -> do+ link_URL <- revision_blog_URL prev_rev_ID+ return $ ( "prev-blog-update"+ , prev_rev_ID + ) :+ ( "prev-blog-update-URL"+ , link_URL+ ) : []+ Just (WikiBloggable prev_entry_path prev_rev_ID _) -> do+ link_URL <- entry_at_rev_URL prev_entry_path prev_rev_ID+ return $ ( "prev-node-update"+ , prev_entry_path+ ) : + ( "prev-node-update-rev"+ , prev_rev_ID+ ) :+ ( "prev-node-update-URL"+ , link_URL+ ) : []+ return $ defaultWriterOptions+ { writerHtml5 = True+ , writerHTMLMathMethod = MathJax "http://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML"+ , writerEmailObfuscation = JavascriptObfuscation+ , writerStandalone = True+ , writerVariables = extra_vars ++ writerVariables defaultWriterOptions+ , writerTemplate = [heredoc|+$for(include-before)$+$include-before$+$endfor$+$if(title)$+<header>+<h1 class="title">$title$</h1>+$for(author)$+<h2 class="author">$author$</h2>+$endfor$+$if(date)$+<h3 class="date">$date$</h3>+$endif$+</header>+$endif$+$if(toc)$+<nav id="$idprefix$TOC">+$toc$+</nav>+$endif$+$body$+$for(include-after)$+$include-after$+$endfor$+<div class="previous_update_summary">+$if(prev-node-update)$+Previously, node $prev-node-update$ was modified to revision <a href="$prev-node-update-URL$">$prev-node-update-rev$</a>+$endif$+$if(prev-blog-update)$+Previously, blog for update revision <a href="$prev-blog-update-URL$">$prev-blog-update$</a>+$endif$+</div>+|]+ }++build_blog_HTML :: ( MonadIO m, ConfigM master m )+ => Maybe Bloggable + -> RevisionId + -> String + -> m ()+build_blog_HTML mprev_update rev_ID txt = do+ out_path <- asks blog_HTML_path <*> pure rev_ID+ out_exists <- liftIO $ doesFileExist out_path + case out_exists of+ True -> return ()+ False -> do+ liftIO $ putStrLn $ "build HTML for " ++ rev_ID ++ " log"+ let pandoc = readMarkdown defaultParserState txt+ write_opts <- pandoc_write_options mprev_update+ let html_string = writeHtmlString write_opts pandoc+ liftIO $ cache_str out_path html_string+ +build_node_HTML :: ( MonadIO m, StoreM m, ConfigM master m )+ => Maybe Bloggable + -> RevisionId + -> FilePath + -> m ()+build_node_HTML mprev_update rev_ID node_path = do+ out_path <- asks node_HTML_path <*> pure rev_ID <*> pure node_path+ out_exists <- liftIO $ doesFileExist out_path+ case out_exists of+ True -> return ()+ False -> do+ liftIO $ putStrLn $ "build HTML for " ++ node_path ++ " " ++ show rev_ID+ store_data <- data_for_node_rev node_path rev_ID+ let markdown_data = FileStore.toByteString store_data+ markdown_text = TL.unpack $ TL.decodeUtf8 markdown_data+ pandoc = readMarkdown defaultParserState markdown_text+ write_opts <- pandoc_write_options mprev_update+ let html_string = writeHtmlString write_opts pandoc+ liftIO $ cache_str out_path html_string+
+ src/Yesod/CoreBot/Bliki/Config.hs view
@@ -0,0 +1,57 @@+module Yesod.CoreBot.Bliki.Config where++import Yesod.CoreBot.Bliki.Prelude++import Yesod.CoreBot.Bliki.DB+import Yesod.CoreBot.Bliki.Store++import Control.Monad.Reader.Class++import Data.FileStore ( RevisionId )++import qualified Data.Text as Text++data Data_ master = Data + { config :: Config master+ , store :: Store+ , update_thread_ID :: ThreadId+ , db_ref :: IORef DB+ }++data Blog_ master = Blog ( Data_ master )++data Wiki_ master = Wiki ( Data_ master )++data Static + = UseServer String+ | UseDir FilePath++-- I don't think there is a way to do subsites of subsites in Yesod? +-- Widgets that need to build links need the master routes?+data Config master where+ Config :: Yesod master => + { store_dir :: FilePath+ , cache_dir :: FilePath+ , data_routes :: Route ( Data_ master ) -> Route master+ , blog_routes :: Route ( Blog_ master ) -> Route master+ , wiki_routes :: Route ( Wiki_ master ) -> Route master+ , static_routes :: Route Static -> Route master+ , static_config :: Static+ , site :: master+ } -> Config master++class ( Applicative m, MonadReader m, Yesod master, EnvType m ~ Config master ) => ConfigM master m+instance ( Applicative m, MonadReader m, Yesod master, EnvType m ~ Config master ) => ConfigM master m++node_markdown_path :: Yesod master => Config master -> FilePath -> FilePath+node_markdown_path config node_path =+ store_dir config </> node_path++blog_HTML_path :: Yesod master => Config master -> RevisionId -> FilePath+blog_HTML_path config rev_ID = + cache_dir config </> rev_ID </> "_log"++node_HTML_path :: Yesod master => Config master-> RevisionId -> FilePath -> FilePath+node_HTML_path config rev_ID node_path = + cache_dir config </> rev_ID </> node_path+
+ src/Yesod/CoreBot/Bliki/DB.hs view
@@ -0,0 +1,89 @@+module Yesod.CoreBot.Bliki.DB where++import Yesod.CoreBot.Bliki.Prelude++import Control.Monad.Reader+import Control.Monad.State.Strict ++import Data.FileStore ( Revision(..) + , TimeRange(..)+ , Resource+ , RevisionId+ )+import qualified Data.FileStore as FileStore++import Data.Map ( Map )+import qualified Data.Map as Map++import Data.Time.Clock++data DataUpdate + = Tweet+ { update_rev_ID :: RevisionId + , tweet_text :: String+ }+ | BlogAdded+ { update_rev_ID :: RevisionId + , blog_text :: String+ }+ | EntryAdded+ { update_rev_ID :: RevisionId+ , update_entry_path :: FilePath+ }+ | EntryChanged + { update_rev_ID :: RevisionId + , update_entry_path :: FilePath+ }+ | Wibble+ { update_rev_ID :: RevisionId+ }+ deriving ( Show, Eq )++data Bloggable = WikiBloggable+ { blog_entry :: String+ , view_rev :: RevisionId+ , prev_bloggable :: Maybe Bloggable+ } | UpdateBloggable+ { blog_str :: String+ , source_rev :: RevisionId+ , prev_bloggable :: Maybe Bloggable+ }++-- XXX The order is always assumed to be from newest to oldest in the lists. This should be+-- checked/enforced.+-- XXX Use a database store like SQLite+data DB = DB+ { raw_history :: [ Revision ]+ , update_log :: [ DataUpdate ]+ , latest_revisions :: Map FilePath RevisionId+ , bloggables :: [ Bloggable ]+ }++history_to_updates :: [ Revision ] -> [ DataUpdate ]+history_to_updates (r : rs) = revision_to_updates r ++ history_to_updates rs++revision_to_updates :: Revision -> [ DataUpdate ]+revision_to_updates r = + let txt = FileStore.revDescription r+ rev_ID = FileStore.revId r+ in map ( classify_change rev_ID ) ( FileStore.revChanges r )+ ++ case length txt of+ txt_len | txt_len > 200 -> [ BlogAdded rev_ID txt ]+ | txt_len > 8 -> [ Tweet rev_ID txt ]+ | otherwise -> [ Wibble rev_ID ]++classify_change rev_ID (FileStore.Added page_path) = + case head page_path of + '.' -> Wibble rev_ID+ _ -> EntryAdded rev_ID page_path+classify_change rev_ID (FileStore.Deleted page_path) = Wibble rev_ID+classify_change rev_ID (FileStore.Modified page_path) = + case head page_path of+ '.' -> Wibble rev_ID+ _ -> EntryChanged rev_ID page_path++head_time :: IORef DB -> IO UTCTime+head_time db_ref = do+ db <- readIORef db_ref+ return $ FileStore.revDateTime $ head $ raw_history db+
+ src/Yesod/CoreBot/Bliki/Prelude.hs view
@@ -0,0 +1,60 @@+module Yesod.CoreBot.Bliki.Prelude ( module Yesod.CoreBot.Bliki.Prelude+ , module Control.Applicative+ , module Control.Concurrent+ , module Control.Monad+ , module Control.Monad.Fix+ , module Data.Aeson+ , module Data.FileStore+ , module Data.IORef+ , module Data.List+ , module Data.Maybe+ , module Data.Monoid+ , module Data.Text+ , module System.FilePath+ , module Yesod+ )+where++import Yesod hiding ( delete+ , deleteBy+ , insert + , insertBy+ , get+ , object+ )++import Blaze.ByteString.Builder ( toByteString )++import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.Fix++import Data.Aeson++import Data.FileStore ( FileStore+ , Revision(..) + , TimeRange(..)+ , Resource+ , RevisionId+ )++import Data.IORef+import Data.List+import Data.Maybe+import Data.Monoid++import qualified Data.Text as Text+import qualified Data.Text.Encoding as TextEnc+import Data.Text (Text)++import Network.HTTP.Types ++import System.FilePath hiding ( joinPath )++render_absolute_URL :: RenderRoute r => Text -> Route r -> Text+render_absolute_URL base_URL r = + let route_subpath = fst $ renderRoute r+ route_sub_URL = TextEnc.decodeUtf8 $ toByteString $ encodePathSegments route_subpath+ in base_URL `Text.append` route_sub_URL+
+ src/Yesod/CoreBot/Bliki/Resources/Base.hs view
@@ -0,0 +1,54 @@+module Yesod.CoreBot.Bliki.Resources.Base ( module Yesod.CoreBot.Bliki.Resources.Base+ ) where++import Yesod.CoreBot.Bliki.Prelude++import Yesod.CoreBot.Bliki.Config+import Yesod.CoreBot.Bliki.DB+import Yesod.CoreBot.Bliki.Store++import Control.Concurrent+import Control.Monad.Reader.Class++import qualified Data.Text as Text++mkYesodSubData "Data_ master" [] [parseRoutes|+/latest LatestR GET+/ UpdateLogR GET+/entry/*Texts EntryLatestR GET+/blog/#RevisionId BlogR GET +/rev/#RevisionId/*Texts EntryRevR GET+|]++mkYesodSubData "Blog_ master" [] [parseRoutes|+/ BlogIndexR GET+|]++mkYesodSubData "Wiki_ master" [] [parseRoutes|+/*Texts WikiIndexR GET+|]++mkYesodSubData "Static" [] [parseRoutes|+/#String FileR GET+|]++revision_blog_URL :: ConfigM master m+ => RevisionId + -> m String+revision_blog_URL rev_ID = do+ config :: Config master <- ask+ let base_URL = approot $ site config+ rev_blog_R = data_routes config $ BlogR rev_ID+ return $ Text.unpack $ render_absolute_URL base_URL rev_blog_R+ + +entry_at_rev_URL :: ConfigM master m+ => String + -> RevisionId + -> m String+entry_at_rev_URL entry_path rev_ID = do+ config :: Config master <- ask+ let base_URL = approot $ site config+ entry_rev_R = data_routes config $ EntryRevR rev_ID [ Text.pack entry_path ]+ return $ Text.unpack $ render_absolute_URL base_URL entry_rev_R+
+ src/Yesod/CoreBot/Bliki/Resources/Blog.hs view
@@ -0,0 +1,59 @@+module Yesod.CoreBot.Bliki.Resources.Blog where++import Yesod.CoreBot.Bliki.Prelude++import Yesod.CoreBot.Bliki.Resources.Base++import Yesod.CoreBot.Bliki.Config +import Yesod.CoreBot.Bliki.DB +import Yesod.CoreBot.Bliki.Store ++import qualified Data.Text as Text++mk_blog :: Data_ master -> IO ( Blog_ master )+mk_blog src_data = return $ Blog src_data ++-- XXX: needs json representation+getBlogIndexR :: Yesod master => GHandler ( Blog_ master ) master RepHtml+getBlogIndexR = do+ blog@(Blog src_data) <- getYesodSub+ db <- liftIO $ readIORef $ db_ref src_data+ let updates = take 50 $ update_log db+ update_summaries = build_summaries updates+ build_summaries [] = []+ build_summaries ( Tweet _ txt : us ) + = [whamlet|+ <p .tweet> #{txt}+ |] : build_summaries us+ build_summaries ( BlogAdded _ txt : us )+ = [whamlet|+ <p .blog_summary> #{take 200 txt}+ |] : build_summaries us+ build_summaries ( EntryAdded _ node_path : us ) = + let node_R = data_routes (config src_data) $ EntryLatestR []+ in [whamlet|+ <p .node_update>+ Added + <a href=@{node_R}/#{node_path}>#{node_path}+ |] : build_summaries us+ build_summaries ( EntryChanged _ node_path : us ) = + let node_R = data_routes (config src_data) $ EntryLatestR []+ in [whamlet|+ <p .node_update>+ Changed + <a href=@{node_R}/#{node_path}>#{node_path}+ |] : build_summaries us+ build_summaries ( Wibble _ : us )+ = build_summaries us+ defaultLayout $ do+ [whamlet|+<div .update_log>+ <ol .summary_listing>+ $forall summary <- update_summaries+ <li> ^{summary} +|]++mkYesodSubDispatch "Blog_ master" [] [parseRoutes|+/ BlogIndexR GET+|]+
+ src/Yesod/CoreBot/Bliki/Resources/Data.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE NamedFieldPuns #-}+module Yesod.CoreBot.Bliki.Resources.Data where++import Yesod.CoreBot.Bliki.Prelude ++import Yesod.CoreBot.Bliki.Resources.Base ++import Yesod.CoreBot.Bliki.Cache.UpdateHTML+import Yesod.CoreBot.Bliki.Config+import Yesod.CoreBot.Bliki.DB+import Yesod.CoreBot.Bliki.Store++import Control.Monad.Reader hiding ( lift )+import Control.Monad.State.Strict hiding ( lift )++import qualified Data.FileStore as FileStore++import Data.Map ( Map )+import qualified Data.Map as Map++import qualified Data.Text as T++import Data.Time.Clock+import Data.Time.Clock.POSIX++import System.Directory ( createDirectory+ , doesDirectoryExist+ , removeDirectoryRecursive + )++-- XXX: should be a RWST+type DataM master a = StateT DB ( StateT Store (ReaderT ( Config master ) IO) ) a++process_revisions :: Yesod master => ( Config master, Store ) -> IORef DB -> [ Revision ] -> IO ()+process_revisions ( config, store ) db_ref rs = do+ db <- readIORef db_ref+ let db_mod = execStateT (apply_revisions rs) db+ db' <- runReaderT ( evalStateT db_mod store ) config + writeIORef db_ref db'++apply_revisions :: Yesod master => [ Revision ] -> DataM master ()+apply_revisions [] = do+ return ()+apply_revisions [ r ] = do+ let new_updates = revision_to_updates r+ apply_updates new_updates+ modify $ \db -> db { raw_history = r : raw_history db }+ return ()+apply_revisions (r : r_prev : rs) = do+ apply_revisions ( r_prev : rs )+ let new_updates = revision_to_updates r+ apply_updates new_updates+ modify $ \db -> db { raw_history = r : raw_history db }+ return ()++apply_updates :: Yesod master => [ DataUpdate ] -> DataM master ()+apply_updates [] = do+ return ()+apply_updates ( u : us ) = do+ apply_updates us+ modify $ \db -> db { update_log = u : update_log db }+ f u + where + f ( Wibble _ ) = do+ return ()++ f ( Tweet _ _ ) = do+ return ()++ f ( BlogAdded update_rev_ID blog_str ) = do+ b <- add_bloggable $ UpdateBloggable blog_str update_rev_ID+ build_blog_HTML ( prev_bloggable b ) update_rev_ID blog_str++ f ( EntryAdded update_rev_ID update_entry_path ) = do+ revs <- gets latest_revisions+ let revs' = Map.insert update_entry_path update_rev_ID revs+ modify $ \db -> db { latest_revisions = revs' }+ b <- add_bloggable $ WikiBloggable update_entry_path update_rev_ID+ lift $ build_node_HTML (prev_bloggable b) update_rev_ID update_entry_path++ f ( EntryChanged update_rev_ID update_entry_path ) = do + revs <- gets latest_revisions+ let revs' = Map.insert update_entry_path update_rev_ID revs+ modify $ \db -> db { latest_revisions = revs' }+ bs <- gets bloggables+ b <- case bs of+ ( WikiBloggable blog_entry view_rev prev_bloggable : rest_bs )+ | blog_entry == update_entry_path -> do+ let b' = WikiBloggable blog_entry update_rev_ID prev_bloggable+ modify $ \db -> db { bloggables = b' : rest_bs }+ return b'+ _ -> do+ add_bloggable $ WikiBloggable update_entry_path update_rev_ID + lift $ build_node_HTML ( prev_bloggable b ) update_rev_ID update_entry_path++add_bloggable :: ( Maybe Bloggable -> Bloggable ) -> DataM master Bloggable+add_bloggable fb = do+ bs <- gets bloggables+ let b = case bs of+ [] -> fb Nothing+ b_prev : _ -> fb $ Just b_prev+ modify $ \db -> db { bloggables = b : bs }+ return b++-- XXX: Should be event driven but that'd be harder+update_thread :: Yesod master => ( Config master, Store ) -> IORef DB -> IO ()+update_thread ( config, store ) db_ref = do+ -- XXX: Lower bound to FileStore.history is not exclusive+ let inc_a_bit = addUTCTime (fromInteger 1)+ prev_time_ref <- newIORef =<< return . inc_a_bit =<< head_time db_ref+ let update_thread_ = do+ prev_time <- readIORef prev_time_ref+ putStrLn $ "probing for changes since " ++ show prev_time+ rs <- FileStore.history ( filestore store ) + [] + ( TimeRange (Just prev_time) + Nothing+ )+ case null rs of+ True -> return ()+ False -> do+ putStrLn "found updates"+ process_revisions ( config, store ) db_ref rs+ writeIORef prev_time_ref =<< return . inc_a_bit + =<< head_time db_ref+ -- delay before probing for updates again+ threadDelay 10000000+ forever update_thread_++mk_data :: Yesod master => Config master -> IO ( Data_ master )+mk_data config = do+ -- clear memoization store+ should_clear_memo_store <- doesDirectoryExist $ cache_dir config+ when should_clear_memo_store $ removeDirectoryRecursive $ cache_dir config+ createDirectory $ cache_dir config+ -- build internal DB state+ let filestore = FileStore.gitFileStore $ store_dir config+ store = Store { filestore = filestore }+ empty_db = DB [] [] Map.empty []+ initial_history <- FileStore.history filestore [] (TimeRange Nothing Nothing) + let db_0_build = execStateT (apply_revisions initial_history) empty_db+ db_ref <- newIORef =<< runReaderT (evalStateT db_0_build store) config+ -- XXX: Only because store is not pure value but a reference+ the_ID <- forkIO $ update_thread ( config, store ) db_ref+ return Data { config = config+ , store = store+ , update_thread_ID = the_ID+ , db_ref = db_ref+ }++node_HTML_content :: Yesod master => Data_ master -> DB -> FilePath -> Content+node_HTML_content src_data db node_path = + let Just rev_ID = Map.lookup node_path ( latest_revisions db )+ out_path = node_HTML_path (config src_data) rev_ID node_path+ in ContentFile out_path Nothing++blog_HTML_content :: Yesod master => Data_ master -> RevisionId -> Content+blog_HTML_content src_data rev_ID = + let out_path = blog_HTML_path (config src_data) rev_ID+ in ContentFile out_path Nothing++getBlogR :: Yesod master => RevisionId -> GHandler ( Data_ master ) master [(ContentType, Content)]+getBlogR rev_ID = do+ src_data <- getYesodSub+ let out_HTML_content = blog_HTML_content src_data rev_ID+ return [ ( typeHtml, out_HTML_content )+ ]+ +getLatestR :: Yesod master => GHandler ( Data_ master ) master [(ContentType, Content)]+getLatestR = do+ src_data <- getYesodSub + db <- liftIO $ readIORef $ db_ref src_data+ let latest = head $ bloggables db+ case latest of+ UpdateBloggable blog_str source_rev _ -> do+ let out_HTML = blog_HTML_content src_data source_rev+ return [ ( typeHtml, out_HTML )+ , ( typePlain, toContent blog_str )+ ]+ WikiBloggable blog_entry _ _ -> do+ let markdown_path = node_markdown_path (config src_data) blog_entry+ let out_HTML = node_HTML_content src_data db blog_entry+ return [ ( typeHtml , out_HTML )+ , ( typePlain, ContentFile markdown_path Nothing ) + ]++getUpdateLogR :: Yesod master => GHandler ( Data_ master ) master RepJson+getUpdateLogR = do+ jsonToRepJson $ toJSON ()++getEntryRevR :: Yesod master + => RevisionId + -> [ Text ] + -> GHandler ( Data_ master ) master [(ContentType, Content)]+getEntryRevR rev_ID entry_path_texts = do+ src_data <- getYesodSub+ let ( first_path : rest_paths ) = map T.unpack entry_path_texts+ node_path = foldl (</>) first_path rest_paths+ let p = node_HTML_path (config src_data) rev_ID node_path+ let markdown_path = node_markdown_path (config src_data) node_path+ return [ ( typeHtml , ContentFile p Nothing )+ , ( typePlain, ContentFile markdown_path Nothing ) + ]+ +getEntryLatestR :: Yesod master => [ Text ] -> GHandler ( Data_ master ) master [(ContentType, Content)]+getEntryLatestR entry_path_texts = do+ let ( first_path : rest_paths ) = map T.unpack entry_path_texts+ node_path = foldl (</>) first_path rest_paths+ src_data <- getYesodSub+ db <- liftIO $ readIORef $ db_ref src_data+ let x = Map.lookup node_path ( latest_revisions db )+ case x of+ Nothing -> do+ liftIO $ putStrLn $ "no node at path " ++ show node_path+ fail $ "no node at path " ++ show node_path+ Just rev_ID -> do+ liftIO $ putStrLn $ "latest rev of " ++ show node_path ++ " is " ++ show rev_ID+ getEntryRevR rev_ID entry_path_texts++mkYesodSubDispatch "Data_ master" [] [parseRoutes|+/latest LatestR GET+/ UpdateLogR GET+/entry/*Texts EntryLatestR GET+/blog/#RevisionId BlogR GET +/rev/#RevisionId/*Texts EntryRevR GET+|]+
+ src/Yesod/CoreBot/Bliki/Resources/Static.hs view
@@ -0,0 +1,29 @@+module Yesod.CoreBot.Bliki.Resources.Static where++import Yesod.CoreBot.Bliki.Prelude++import Yesod.CoreBot.Bliki.Base+import Yesod.CoreBot.Bliki.Config+import Yesod.CoreBot.Bliki.Resources.Base++import System.Directory ( doesFileExist )++getFileR :: Yesod m => String -> GHandler Static m ()+getFileR file_name = do+ mode <- getYesodSub+ case mode of+ UseServer server -> fail "XXX: UseServer server should not be hit"+ UseDir dir -> do+ let file_path = dir </> file_name+ file_type = case takeExtension file_path of+ ".js" -> typeJavascript+ _ -> typePlain+ exists <- liftIO $ doesFileExist file_path+ case exists of+ True -> sendFile file_type file_path+ False -> notFound+ +mkYesodSubDispatch "Static" [] [parseRoutes|+/#String FileR GET+|]+
+ src/Yesod/CoreBot/Bliki/Resources/Wiki.hs view
@@ -0,0 +1,43 @@+module Yesod.CoreBot.Bliki.Resources.Wiki where++import Yesod.CoreBot.Bliki.Prelude++import Yesod.CoreBot.Bliki.Base+import Yesod.CoreBot.Bliki.Config+import Yesod.CoreBot.Bliki.Store +import Yesod.CoreBot.Bliki.Resources.Base++import Control.Monad.State.Strict++import Data.FileStore+import qualified Data.Text as Text+import Data.Time.Clock.POSIX++mk_wiki :: Data_ master -> IO ( Wiki_ master )+mk_wiki src_data = return $ Wiki src_data ++-- XXX: needs json representation+getWikiIndexR :: Yesod master => [ Text ] -> GHandler ( Wiki_ master ) master RepHtml+getWikiIndexR node_path = do+ liftIO $ putStrLn $ "index for node " ++ show node_path+ wiki@(Wiki src_data) <- getYesodSub+ defaultLayout $ do+ let store_path = foldl (</>) "" $ map Text.unpack node_path+ listing <- evalStateT (directory_listing store_path) ( store src_data )+ let entry_names = [ Text.pack name | FSFile name <- listing ]+ node_names = [ Text.pack name | FSDirectory name <- listing ]+ let data_URL = data_routes (config src_data) $ EntryLatestR []+ index_URL = wiki_routes (config src_data) $ WikiIndexR []+ [whamlet|+ <div .wiki_index>+ <ul>/#{store_path}+ $forall node_name <- node_names+ <li .node_name><a href=@{index_URL}/#{store_path}/#{node_name}>#{node_name}+ $forall entry_name <- entry_names+ <li .entry_name><a href=@{data_URL}/#{store_path}/#{entry_name}>#{entry_name}+|]++mkYesodSubDispatch "Wiki_ master" [] [parseRoutes|+/*Texts WikiIndexR GET+|]+
+ src/Yesod/CoreBot/Bliki/Store.hs view
@@ -0,0 +1,47 @@+module Yesod.CoreBot.Bliki.Store where++import Yesod.CoreBot.Bliki.Prelude++import Control.Monad.State.Class+import Control.Monad.Trans++import qualified Data.ByteString.Lazy as B++import qualified Data.FileStore as FileStore++import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL++import System.Directory++-- XXX: The inner FileStore is not actually pure.+data Store = Store+ { filestore :: FileStore+ }++class ( MonadIO m, Applicative m, MonadState m, StateType m ~ Store ) => StoreM m+instance ( MonadIO m, Applicative m, MonadState m, StateType m ~ Store ) => StoreM m++directory_listing :: StoreM m => FilePath -> m [ Resource ]+directory_listing node_path = do+ store <- get+ liftIO $ FileStore.directory (filestore store) node_path++cache_str :: FilePath -> String -> IO ()+cache_str out_path str = do+ let text = TL.pack str+ bs = TL.encodeUtf8 text+ tmp_out = out_path ++ ".tmp"+ createDirectoryIfMissing True (takeDirectory tmp_out)+ B.writeFile tmp_out bs+ renameFile tmp_out out_path+ return ()++data_for_node_rev :: StoreM m+ => FilePath + -> RevisionId + -> m B.ByteString+data_for_node_rev node_path rev_ID = do+ fs <- gets filestore+ liftIO $ FileStore.smartRetrieve fs True node_path (Just rev_ID) +
+ src/Yesod/CoreBot/Bliki/Widgets.hs view
@@ -0,0 +1,17 @@+{- Widgets useful for building the wiki site. + - See DefaultMain.hs for an example of all of these in use at once.+ -}+module Yesod.CoreBot.Bliki.Widgets where++import Yesod.CoreBot.Bliki.Prelude++import Yesod.CoreBot.Bliki.Base+import Yesod.CoreBot.Bliki.Config+import Yesod.CoreBot.Bliki.Resources.Base++data NavWidget = NavWidget++instance ToWidget sub master NavWidget where+ toWidget _ = do+ return ()+