geek 1.0.0.3 → 1.0.0.4

raw patch · 10 files changed

+306/−271 lines, 10 filesdep +moePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: moe

API changes (from Hackage documentation)

Files

• geek.cabal +6/−4
• readme.md +0/−53
• src/Web/Geek/Application.hs +88/−138
• src/Web/Geek/Config.hs +9/−14
• src/Web/Geek/DefaultConfig.hs +5/−0
• src/Web/Geek/Post.hs +18/−23
• src/Web/Geek/RSS.hs +111/−0
• src/Web/Geek/Runtime.hs +61/−29
• src/Web/Geek/Serve.hs +3/−4
• src/Web/Geek/Type.hs +5/−6

@@ -1,5 +1,5 @@ Name:                 geek-Version:              1.0.0.3+Version:              1.0.0.4 Build-type:           Simple Synopsis:             Geek blog engine Description:          A dynamic blog engine, customizable with standard web technology, i.e. HTML, CSS and Javascript (JSON)@@ -12,8 +12,8 @@ Cabal-version:        >= 1.6 category:             Web homepage:             http://github.com/nfjinjing/geek-data-files:           readme.md-                    , Nemesis+data-files:           +                      Nemesis                     , src/Web/Geek/ImportFromBamboo.hs                      @@ -48,6 +48,7 @@                     , text-icu                     , time                     , uuid+                    , moe                         hs-source-dirs:     src/@@ -57,7 +58,8 @@                       Web.Geek.DefaultConfig                       Web.Geek.DemoMiddlewareStack                       Web.Geek.Post+                      Web.Geek.RSS+                      Web.Geek.Runtime                       Web.Geek.Serve                       Web.Geek.Spec                       Web.Geek.Type-                      Web.Geek.Runtime

@@ -1,53 +0,0 @@-Geek-=====--A dynamic blog engine, customizable with standard web technology, i.e. HTML, CSS and Javascript (JSON)--Features-----------* Write posts in Markdown-* Full text search-* Layout is configurable through HTML, CSS and Javascript-* [Jekyll's front matter](http://jekyllrb.com/docs/frontmatter/) compatible--Installation---------------### Install Geek--    cabal install geek-server--### Get a Geek Blog Seed--    git clone https://github.com/nfjinjing/geek-blog-seed-jinjing-angular-mini.git geek-blog---Start----------    cd geek-blog-    geek geek-config.sh---Check---------<http://localhost:3001>---Configuration-----------------### Basic--* Geek Server: `geek-config.sh`-* Blog: `blog/angular/app/js/site-config.js`-* Layout: `blog/angular/index`, `blog/angular/partials`-* Style: `blog/angular/css/app.css`--Writing posts---------------* See `posts` directory for examples-* Posts are compatible with [Jekyll's front matter](http://jekyllrb.com/docs/frontmatter/) format

@@ -8,63 +8,46 @@ import Air.Data.Record.SimpleLabel hiding (get) import Air.Env import Air.Extra hiding (date)-import Air.Spec-import Air.TH (mkDefault, here)-import Control.Concurrent.Chan-import Control.Monad hiding (join, get)+import Air.TH (here) import Control.Monad.Reader (ask)+import Control.Monad.State (modify) import Data.Aeson.Encode.Pretty (encodePretty)-import Data.Aeson.Generic (encode, decode) import Data.Aeson.Generic (toJSON) import Data.Function (on)-import Data.IORef-import Data.List (find, sort)-import Data.List (sortBy)-import Data.Map (Map)+import Data.IORef (readIORef)+import Data.List (find, sortBy) import Data.Map (toAscList) import Data.Maybe (fromMaybe, catMaybes) import Data.Text (Text) import Data.Text.Encoding-import Data.Time (formatTime, fromGregorianValid, UTCTime(..))-import Data.UUID (toString)-import Filesystem.Path.CurrentOS (encodeString, decodeString)-import Hack2 (Application, Middleware)+import Data.Time (fromGregorianValid, UTCTime(..))+import Data.ByteString (ByteString)+import Hack2 (Application) import Hack2.Contrib.Middleware.File (serve) import Hack2.Contrib.Middleware.Static import Hack2.Contrib.Request (params)-import Hack2.Contrib.Response-import Hack2.Contrib.Utils (use, unescape_uri, query_string)+import Hack2.Contrib.Response (set_content_type)+import Hack2.Contrib.Utils (use, unescape_uri) import Network.Miku hiding (json) import Network.Miku.Type (AppMonadT) import Safe (readMay)-import System.Directory-import System.FSNotify-import System.FilePath-import System.FilePath.Glob-import System.Locale (defaultTimeLocale)-import System.Random-import Test.Hspec-import Text.Printf-import Web.Geek.Config-import Web.Geek.DefaultConfig-import Web.Geek.Post import Web.Geek.Runtime import Web.Geek.Type+import Web.Geek.RSS import qualified Control.Monad.State as State import qualified Data.ByteString.Char8 as B import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.ICU as ICU-import qualified Data.Text.IO as TextIO import qualified Network.Miku as Miku import qualified Prelude as P-import qualified Prelude as P+import Control.Arrow ((***))   initialize_geek :: Config -> [MarkupEngine] -> IO Application-initialize_geek _config markup_engines = do-  _runtime <- initialize_runtime _config markup_engines+initialize_geek _config _markup_engines = do+  _runtime <- initialize_runtime _config _markup_engines      let geek_app = geek _runtime @@ -79,9 +62,9 @@          _middleware = use static_serve_stack     -  let app = _middleware geek_app+  let _app = _middleware geek_app   -  return app+  return _app                 @@ -113,20 +96,20 @@        -- Miku stuff -    read_posts :: AppMonadT [Post]-    read_posts = io - readIORef - runtime.posts_ref+    read_posts :: IO [Post]+    read_posts = readIORef - runtime.posts_ref -    filter_posts_by_query :: Text -> AppMonadT [Post]-    filter_posts_by_query _query_text = do+    read_posts_by_query :: Text -> IO [Post]+    read_posts_by_query _query_text = do       _posts <- read_posts       if _query_text.T.null         then return _posts         else do-          _full_text_search_map <- io - readIORef - runtime.full_text_search_map_ref+          _full_text_search_map <- readIORef - runtime.full_text_search_map_ref            let _lowered_query_text = ICU.toLower ICU.Current _query_text -              _number_of_maximum_tokens = 7+              _number_of_maximum_tokens = 7 :: Int                _query_tokens = _lowered_query_text.T.words.take _number_of_maximum_tokens @@ -149,6 +132,37 @@                 .to_list            return - matched_post_ids.map (\_id -> _posts.at _id) .catMaybes.sortBy (compare `on` date).reverse+    +    text_params :: AppMonadT [(Text, Text)]+    text_params = do+      _params <- ask ^ params+      return - _params.map (decodeUtf8 *** decodeUtf8)+  +    text_captures :: AppMonadT [(Text, Text)]+    text_captures = do+      _captures <- captures+      return - _captures.map (decodeUtf8 *** (B.unpack > b2u > unescape_uri > T.pack))+  +    lookup_non_empty_and_stripped :: Text -> [(Text, Text)] -> Maybe Text+    lookup_non_empty_and_stripped x xs = +      case xs.lookup x of+        Nothing -> Nothing+        Just _found ->+          let _stripped = _found.T.strip+          in+          +          if _stripped.T.null+             then+               Nothing+              else+                Just _stripped+    ++    filter_posts_by_tag :: [Post] -> Maybe Text -> [Post]+    filter_posts_by_tag _posts _maybe_tag = +      case _maybe_tag of +        Nothing -> _posts+        Just _tag -> _posts.select (tags > has _tag)   in      miku - do@@ -156,49 +170,38 @@       _params <- ask ^ params              -      let tag_string = _params.(lookup "tag" > fromMaybe "" > B.unpack > b2u)-          tag_text = tag_string.T.pack.T.strip-          +      _maybe_tag <- text_params ^ lookup_non_empty_and_stripped "tag"              _query_text <- query_text              -- io - printf "query_text: %s" (T.unpack _query_text)       -      _posts_filtered_by_query <- filter_posts_by_query _query_text-      -      _posts_filtered_by_tag_and_query <--        if tag_text.T.null-          then do-            -- io - puts "no tag"-            return _posts_filtered_by_query-          else do-            -- io - puts - "tag: " + show tag_text-            return - _posts_filtered_by_query.select (tags > has tag_text)+      _posts_filtered_by_query <- io - read_posts_by_query _query_text       +      let _posts_filtered_by_tag_and_query = filter_posts_by_tag _posts_filtered_by_query _maybe_tag+          (_drop, _take) <- pager              let paginated_posts = _posts_filtered_by_tag_and_query.drop _drop.take _take              -- io - puts - paginated_posts.map (title > T.unpack).join "\n"       -          clean_raw_body post = post .set __raw_body ""+          clean_raw_body _post = _post .set __raw_body ""                  json- paginated_posts.map clean_raw_body                   get "/posts/:year/:month/:day/:title" - do-      _captures <- captures+      _captures <- text_captures -      posts <- read_posts-      -      +      posts <- io - read_posts              let          _post = fromMaybe def - do-          year <- _captures.lookup "year" >>= B.unpack > readMay-          month <- _captures.lookup "month" >>= B.unpack > readMay-          day <- _captures.lookup "day" >>= B.unpack > readMay-          _title <- _captures.lookup "title" >>= B.unpack > unescape_uri > T.pack > return+          year <- _captures.lookup "year" >>= T.unpack > readMay+          month <- _captures.lookup "month" >>= T.unpack > readMay+          day <- _captures.lookup "day" >>= T.unpack > readMay+          _title <- _captures.lookup "title"                    post_day <- fromGregorianValid year month day         @@ -213,11 +216,11 @@     get "/tags" - do       _query_text <- query_text       -      _posts_filtered_by_query <- filter_posts_by_query _query_text+      _posts_filtered_by_query <- io - read_posts_by_query _query_text       -      _posts <- read_posts+      _posts <- io - read_posts       -      let run_length_encoding base xs = (zip base (repeat (0 :: Integer)) + zip xs (repeat (1 :: Integer))) .Map.fromListWith (P.+)+      let run_length_encoding _base xs = (zip _base (repeat (0 :: Integer)) + zip xs (repeat (1 :: Integer))) .Map.fromListWith (P.+)           unique_tags = _posts.map tags.concat.unique                      all_tags = _posts_filtered_by_query.map tags.concat.run_length_encoding unique_tags@@ -236,85 +239,32 @@        State.put _response       -    {--    get "/post/:title" - do-      _captures <- captures-      posts <- read_posts--      let -        _post = fromMaybe def - do-          _title <- _captures.lookup "title" >>= B.unpack > unescape_uri > T.pack > return-          posts.find (title > is _title)---      json _post--    -}     -    get "*" - do-      text "Unknown route"-  -register_monitor :: WatchManager -> FilePath -> (FilePath -> IO ()) -> IO ()-register_monitor manager path callback = do-  -- printf "reigister_with_path: %s\n" path-  -- -  watchTree manager (decodeString path) (const True) (\event -> do-    -- puts - show event-    action event-    )-  where-    action (Added _path time) = callback - encodeString _path-    action (Modified _path time) = callback - encodeString _path-    action (Removed _path time) = callback - encodeString _path------ Spec--test_meta :: String-test_meta = [here|------layout: post-categories: 日常------|]--spec :: Spec-spec = do-  describe "Server" - do-    let _config = default_config+    -- Feeds     -    it "should list posts" - do-      posts <- get_posts _config []-      -      posts `shouldSatisfy` (null > not)     -      -    it "should callback on change" - do-      let tmp_path = "tmp"-      test_id <- randomIO ^ toString-      let test_path = tmp_path / test_id-    -      createDirectoryIfMissing True test_path-      -      watch_manager <- startManager-      path_chan <- newChan+    let +      rss_tag_controller :: AppMonadT ()+      rss_tag_controller = do+        _posts <- io - read_posts+        +        _maybe_tag <- text_captures ^ lookup_non_empty_and_stripped "tag"       -      register_monitor watch_manager test_path - \file_path -> do-        -- puts - printf "Changed: %s" file_path-        writeChan path_chan file_path +        let _posts_filtered_by_tag_and_query = filter_posts_by_tag _posts _maybe_tag       -      let test_case_id = "callback"-          test_case_path = test_path / test_case_id--      B.writeFile test_case_path "Hello"-      sleep 0.1-      event_paths <- getChanContents path_chan-      stopManager watch_manager+        text - rss _config _posts_filtered_by_tag_and_query _maybe_tag+        +        modify - set_content_type "text/xml"       -      test_case_full_path <- canonicalizePath test_case_path-      removeDirectoryRecursive test_path+    get "/rss.xml" - do+      rss_tag_controller       -      event_paths `shouldSatisfy` (has test_case_full_path)+    get "/:tag/rss.xml" - do+      rss_tag_controller+    +    get "/tag/:tag/rss.xml" - do+      rss_tag_controller+    +    get "*" - do+      text "Unknown route"+  

@@ -5,28 +5,23 @@  module Web.Geek.Config where -import Air.Data.Record.SimpleLabel import Air.Env hiding (mod) import Air.Extra import Air.Spec-import Air.TH (mkDefault, here, mkLabel)+import Air.TH (here) import Data.Aeson.Encode.Pretty (encodePretty)-import Data.Aeson.Generic (encode, decode)+import Data.Aeson.Generic (decode) import Data.Aeson.Generic (toJSON)-import Data.IORef-import Data.Text (Text) import Data.Time-import System.Directory (doesFileExist, makeRelativeToCurrentDirectory)+import System.Directory (doesFileExist) import System.Environment (getArgs) import System.Exit (exitWith, ExitCode(..))-import System.FSNotify-import System.Locale+import System.Locale (defaultTimeLocale) import Test.Hspec import Text.Printf import Web.Geek.DefaultConfig import Web.Geek.Type import qualified Data.ByteString.Char8 as B-import qualified Data.Text as T import qualified Data.Text.IO as TextIO import System.Process (readProcess) @@ -38,10 +33,10 @@ parse_config = s2l > decode  read_config_from_path :: FilePath -> IO (Maybe Config)-read_config_from_path path = do-  config <- readProcess ("." / path) [] ""+read_config_from_path _path = do+  _config <- readProcess ("." / _path) [] ""   -  return - config.u2b.B.pack.parse_config+  return - _config.u2b.B.pack.parse_config   @@ -55,7 +50,7 @@  get_config_from_args :: IO Config get_config_from_args = do-  let default_config_path = "geek-config"+  let default_config_path = "blog/geek-config.hs"      _args <- getArgs   @@ -91,7 +86,7 @@       puts - "Failed to parse the output of: " + _path       puts ""       puts - "Example:"-      puts - 20.times '-'+      puts - (20 :: Int).times '-'       puts ""       puts default_config_string       puts ""

@@ -23,6 +23,11 @@   , maximum_number_of_posts_per_page = 20         , index_file_path = "blog/angular/app/index.html"   , full_text_search = True+  , number_of_posts_per_feed = 20+  , rss_site_title = "Shinny blog"+  , rss_site_description = ""+  , rss_site_link = "http://localhost:3000"+  , rss_site_root_prefix = "/#"   }   where     _static_serve = 

@@ -6,29 +6,24 @@ module Web.Geek.Post where  import Air.Env-import Air.Extra (u2b) import Air.Spec import Air.TH import Data.Aeson.Generic (encode, decode) import Data.Char-import Data.List.Split import Data.Maybe-import Data.Text (Text, pack, unpack, strip, stripStart)+import Data.Text (Text, pack, strip, stripStart) import Data.Time-import Data.Time.Clock (UTCTime(..)) import GHC.Exts( IsString(..) ) import System.FilePath import System.Locale import Test.Hspec import Web.Geek.Config import Web.Geek.Type-import qualified Data.ByteString.Char8 as B import qualified Data.Text as T-import qualified Data.Text as T  post_tags :: Text -> Post -> [Text]-post_tags meta_tag_keyword post = -  case post.meta.lookup meta_tag_keyword of+post_tags _meta_tag_keyword post = +  case post.meta.lookup _meta_tag_keyword of     Nothing -> []     Just s -> s.T.splitOn ",".map T.strip @@ -47,27 +42,27 @@           "post/" + post.title   in   -  text_link.T.unpack.fromString.URIEscapedText+  text_link.T.unpack.fromString  parse_title_and_date_from_path :: String -> FilePath -> (T.Text, Maybe UTCTime)-parse_title_and_date_from_path post_date_format path = +parse_title_and_date_from_path _post_date_format _path =    let-    base_name = path.takeBaseName-    _post_date_length = post_date_length - post_date_format+    base_name = _path.takeBaseName+    _post_date_length = post_date_length - _post_date_format     -    title = base_name.drop _post_date_length-    date = base_name.take _post_date_length.parseTime defaultTimeLocale post_date_format+    _title = base_name.drop _post_date_length+    _date = base_name.take _post_date_length.parseTime defaultTimeLocale _post_date_format   in-  (title.T.pack, date)+  (_title.T.pack, _date)      markup :: [MarkupEngine] -> FilePath -> Text -> HTMLText-markup markups path body = -  let ext = path.takeExtension.dropWhile (is '.').pack+markup markups _path _body = +  let ext = _path.takeExtension.dropWhile (is '.').pack   in      case markups.select (extensions > has ext) of-    [] -> transformer def body-    markup:_ -> transformer markup body+    [] -> transformer def _body+    _markup:_ -> transformer _markup _body  parse_meta :: Text -> (Meta, Text) parse_meta str = @@ -85,9 +80,9 @@                 _ -> Nothing           in           -          let meta = y.T.lines.reject (T.all isSpace).map parse_line.catMaybes+          let _meta = y.T.lines.reject (T.all isSpace).map parse_line.catMaybes           in-          (meta, zs.T.unlines.stripStart)+          (_meta, zs.T.unlines.stripStart)         else           no_meta     _ -> no_meta@@ -114,10 +109,10 @@       parse_meta test_meta === ([("layout", "post"), ("categories", "日常")], "some thing\n\n\n")          it "should parse title" - do-      let path = "blog/posts/2010-10-30-dummy title.md"+      let _path = "blog/posts/2010-10-30-dummy title.md"           title_and_date = ("dummy title", parseTime defaultTimeLocale "%Y-%m-%d" "2010-10-30")           -      parse_title_and_date_from_path "%Y-%m-%d-" path === title_and_date+      parse_title_and_date_from_path "%Y-%m-%d-" _path === title_and_date          {-     it "should markup" - do

@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}+++module Web.Geek.RSS (rss) where++import Air.Data.Record.SimpleLabel hiding (get)+import Air.Env hiding (head, div)+import Air.Extra hiding (date)+import Air.TH (here)++import qualified Web.Geek.Type as Geek+import Data.Text (Text)++import Text.HTML.Moe2 hiding ((/), text)+import Text.HTML.Moe2.Type (MoeUnit)+import Data.ByteString (ByteString)+import qualified Data.Text as T+import Data.Maybe+import Control.Monad (forM_)+import System.Locale (defaultTimeLocale)+import Data.Time (formatTime)++  {-+  +  <?xml version="1.0" encoding="UTF-8"?>+  <rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom">+    <channel>+      <title>{{ site.name }}</title>+      <description>{{ site.description }}</description>+      <link>{{ site.url }}</link>+      <atom:link href="{{ site.url }}/rss.xml" rel="self" type="application/rss+xml" />+      {% for post in site.posts limit:10 %}+        <item>+          <title>{{ post.title }}</title>+          <description>{{ post.content | xml_escape }}</description>+          <pubDate>{{ post.date | date: "%a, %d %b %Y %H:%M:%S %z" }}</pubDate>+          <link>{{ site.url }}{{ post.url }}</link>+          <guid isPermaLink="true">{{ site.url }}{{ post.url }}</guid>+        </item>+      {% endfor %}+    </channel>+  </rss>+  +  <link rel="alternate" type="application/rss+xml" title="{{ site.name }}" href="{{ site.url }}/rss.xml">+  +  -}++-- xml_header +xml_header :: MoeUnit+xml_header = no_escape_no_indent_str "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"++text :: T.Text -> MoeUnit+text = T.unpack > str++rss :: Geek.Config -> [Geek.Post] -> Maybe Text -> ByteString+rss _config _posts _mabye_tag = l2s - render_bytestring - do+  +  let drop_tail_slash xs = xs.reverse.dropWhile (is '/').reverse+  +      site_link = +        (+        [+          _config.Geek.rss_site_link.T.unpack.drop_tail_slash+        , _config.Geek.rss_site_root_prefix.T.unpack.drop_tail_slash.reverse.drop_tail_slash+        ]+        ).join "/"+        +      site_tag_link = +        case _mabye_tag of+          Nothing -> site_link+          Just _tag -> site_link + "/" + _tag.T.unpack+        +  xml_header+  +  element "rss" ! [attr "version" "2.0", attr "xmlns:atom" "http://www.w3.org/2005/Atom"] - do+    element "channel" - do+      title - do+        text - _config.Geek.rss_site_title+        +      element "description" - do+        text - _config.Geek.rss_site_description+        +      element "link" - do++              +        str - site_link+      +      element "atom:link" ! [href (site_tag_link + "/rss.xml"), attr "rel" "self", _type "application/rss+xml"] -+        return ()+      +      forM_ _posts - \_post ->+        element "item" - do+          title - do+            text - _post.Geek.title+          +          element "description" - do+            text - _post.Geek.body.Geek.unHTMLText+          +          element "pubDate" - do+            let pub_date_format_string = "%a, %d %b %Y %H:%M:%S %z"+            str - _post.Geek.date.fromMaybe def.formatTime defaultTimeLocale pub_date_format_string+            +            let post_link = site_link + "/" +  _post.Geek.link.Geek.unURIEscapedText.T.unpack+            element "link" - do+              str - post_link+            element "guid" ! [attr "isPermaLink" "true"] - do+              str - post_link+          +      

@@ -8,55 +8,36 @@ import Air.Data.Record.SimpleLabel hiding (get) import Air.Env import Air.Extra hiding (date)-import Air.Spec-import Air.TH (mkDefault, here) import Control.Concurrent.Chan-import Control.Monad hiding (join, get)-import Control.Monad.Reader (ask)-import Data.Aeson.Generic (encode, decode)+import Control.Monad hiding (join) import Data.Function (on) import Data.IORef-import Data.List (find, sort) import Data.List (sortBy)-import Data.Map (Map)-import Data.Map (toAscList)-import Data.Maybe (fromMaybe, catMaybes) import Data.Text (Text)-import Data.Text.Encoding-import Data.Time (formatTime, fromGregorianValid, UTCTime(..)) import Data.UUID (toString) import Filesystem.Path.CurrentOS (encodeString, decodeString)-import Network.Miku hiding (json)-import Network.Miku.Type (AppMonadT)-import Safe (readMay) import System.Directory import System.FSNotify-import System.FilePath import System.FilePath.Glob-import System.Locale (defaultTimeLocale) import System.Random import Test.Hspec import Text.Printf-import Web.Geek.Config+import Web.Geek.DefaultConfig import Web.Geek.Post import Web.Geek.Type import qualified Data.ByteString.Char8 as B import qualified Data.Map as Map-import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.ICU as ICU import qualified Data.Text.IO as TextIO-import qualified Network.Miku as Miku import qualified Prelude as P  - build_markup_engines :: [Text] -> [MarkupEngine] -> [MarkupEngine] build_markup_engines user_markup_engine_names _markup_engines =    _markup_engines.select (markup_engine_name > belongs_to user_markup_engine_names)  - get_post_from_path :: Config -> [MarkupEngine] -> FilePath -> IO Post get_post_from_path _config _markup_engines _path = do   let _meta_tag_keyword = _config.meta_tag_keyword@@ -91,7 +72,7 @@       .set __tags _tags  glob_dir :: String -> FilePath -> IO [String]-glob_dir pattern path = globDir1 (compile pattern) path+glob_dir pattern _path = globDir1 (compile pattern) _path  get_posts :: Config -> [MarkupEngine] -> IO [Post] get_posts _config _markup_engines = do@@ -104,13 +85,13 @@   return - posts.sortBy (compare `on` date).reverse  monitor_posts :: Config -> [MarkupEngine] -> Chan Event -> IORef [Post] -> IO ()-monitor_posts _config _markup_engines events posts_ref = do+monitor_posts _config _markup_engines events _posts_ref = do   last_event_time_stamp <- now >>= newIORef   last_update_time_stamp <- now >>= newIORef      let     record_event = do-      e <- readChan events+      _ <- readChan events       -- printf "Caught: %s\n" - show e       time_stamp <- now     @@ -120,13 +101,13 @@      let     lazy_update = do-      sleep 0.1+      sleep (0.1 :: Double)       event_time <- readIORef last_event_time_stamp       update_time <- readIORef last_update_time_stamp              if event_time P.> update_time         then do-          get_posts _config _markup_engines >>= writeIORef posts_ref+          get_posts _config _markup_engines >>= writeIORef _posts_ref           now >>= writeIORef last_update_time_stamp                    else@@ -163,17 +144,17 @@      -- print - _full_text_search_map.Map.toAscList.take 50   -  printf "Search database has %i unique keywords." (_full_text_search_map.Map.size)+  puts - printf "Search database has %i unique keywords." (_full_text_search_map.Map.size)      fork - withManager - \watch_manager -> do      events <- newChan :: (IO (Chan Event))-    fork - monitor_posts _config _markup_engines events _posts_ref+    fork - monitor_posts _config _markup_engines events _posts_ref       let post_watch_file_path = decodeString - _config.blog_directory / _config.post_directory     watchTreeChan watch_manager post_watch_file_path (const True) events     -    forever - sleep 1000+    forever - sleep (1000 :: Double)      return -      def @@ -184,4 +165,55 @@       , full_text_search_map_ref = _full_text_search_map_ref       } +register_monitor :: WatchManager -> FilePath -> (FilePath -> IO ()) -> IO ()+register_monitor manager _path callback = do+  -- printf "reigister_with_path: %s\n" path+  -- +  watchTree manager (decodeString _path) (const True) (\event -> do+    -- puts - show event+    action event+    )+  where+    action (Added _path _) = callback - encodeString _path+    action (Modified _path _) = callback - encodeString _path+    action (Removed _path _) = callback - encodeString _path +++spec :: Spec+spec = do+  describe "Server" - do+    let _config = default_config+    +    it "should list posts" - do+      posts <- get_posts _config []+      +      posts `shouldSatisfy` (null > not)+    +      +    it "should callback on change" - do+      let tmp_path = "tmp"+      test_id <- randomIO ^ toString+      let test_path = tmp_path / test_id+    +      createDirectoryIfMissing True test_path+      +      watch_manager <- startManager+      path_chan <- newChan+      +      register_monitor watch_manager test_path - \file_path -> do+        -- puts - printf "Changed: %s" file_path+        writeChan path_chan file_path +      +      let test_case_id = "callback"+          test_case_path = test_path / test_case_id++      B.writeFile test_case_path "Hello"+      sleep (0.1 :: Double)+      event_paths <- getChanContents path_chan+      stopManager watch_manager+      +      test_case_full_path <- canonicalizePath test_case_path+      removeDirectoryRecursive test_path+      +      event_paths `shouldSatisfy` (has test_case_full_path)

@@ -6,9 +6,8 @@ module Web.Geek.Serve where  import Air.Env-import Air.Extra hiding (date) import Hack2-import Hack2.Contrib.Utils (use, unescape_uri)+import Hack2.Contrib.Utils (use) import Web.Geek.Application import Web.Geek.Config (get_config_from_args) import Web.Geek.Type@@ -16,9 +15,9 @@ type Port = Int  serve :: [MarkupEngine] -> [Middleware] -> (Application -> Port -> IO ()) -> IO ()-serve markup_engines middleware_stack server_backend = do+serve _markup_engines middleware_stack server_backend = do   _config <- get_config_from_args-  geek_app <- initialize_geek _config markup_engines+  geek_app <- initialize_geek _config _markup_engines      let _middleware = use middleware_stack       _app = _middleware geek_app

@@ -7,24 +7,18 @@ module Web.Geek.Type where  import Air.Data.Record.SimpleLabel-import Air.Env  import Air.Env hiding (mod) import Air.Heavy (escape_xml)-import Air.TH import Air.TH (mkDefault, here, mkLabel) import Data.Data import Data.IORef import Data.Map (Map) import Data.Text (Text, pack, unpack) import Data.Time-import Data.Typeable import GHC.Exts( IsString(..) ) import Hack2.Contrib.Utils (escape_uri) import Prelude ()-import System.FSNotify-import System.Locale import Text.Printf-import qualified Data.ByteString.Char8 as B import Data.Aeson.Encode.Pretty (encodePretty) import Data.Aeson.Generic (toJSON) import Data.Text.Encoding (decodeUtf8)@@ -99,8 +93,13 @@   , server_port :: Int   , static_serve :: Map Text [Text]   , maximum_number_of_posts_per_page :: Integer+  , number_of_posts_per_feed :: Integer   , index_file_path :: Text   , full_text_search :: Bool+  , rss_site_title :: Text+  , rss_site_description :: Text+  , rss_site_link :: Text+  , rss_site_root_prefix :: Text   }   deriving (Show, Data, Typeable)