diff --git a/geek.cabal b/geek.cabal --- a/geek.cabal +++ b/geek.cabal @@ -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 diff --git a/readme.md b/readme.md deleted file mode 100644 --- a/readme.md +++ /dev/null @@ -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 ------- - - - - -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 diff --git a/src/Web/Geek/Application.hs b/src/Web/Geek/Application.hs --- a/src/Web/Geek/Application.hs +++ b/src/Web/Geek/Application.hs @@ -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" + diff --git a/src/Web/Geek/Config.hs b/src/Web/Geek/Config.hs --- a/src/Web/Geek/Config.hs +++ b/src/Web/Geek/Config.hs @@ -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 "" diff --git a/src/Web/Geek/DefaultConfig.hs b/src/Web/Geek/DefaultConfig.hs --- a/src/Web/Geek/DefaultConfig.hs +++ b/src/Web/Geek/DefaultConfig.hs @@ -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 = diff --git a/src/Web/Geek/Post.hs b/src/Web/Geek/Post.hs --- a/src/Web/Geek/Post.hs +++ b/src/Web/Geek/Post.hs @@ -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 diff --git a/src/Web/Geek/RSS.hs b/src/Web/Geek/RSS.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/RSS.hs @@ -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) + + {- + + + + + {{ site.name }} + {{ site.description }} + {{ site.url }} + + {% for post in site.posts limit:10 %} + + {{ post.title }} + {{ post.content | xml_escape }} + {{ post.date | date: "%a, %d %b %Y %H:%M:%S %z" }} + {{ site.url }}{{ post.url }} + {{ site.url }}{{ post.url }} + + {% endfor %} + + + + + + -} + +-- xml_header +xml_header :: MoeUnit +xml_header = no_escape_no_indent_str "" + +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 + + diff --git a/src/Web/Geek/Runtime.hs b/src/Web/Geek/Runtime.hs --- a/src/Web/Geek/Runtime.hs +++ b/src/Web/Geek/Runtime.hs @@ -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) diff --git a/src/Web/Geek/Serve.hs b/src/Web/Geek/Serve.hs --- a/src/Web/Geek/Serve.hs +++ b/src/Web/Geek/Serve.hs @@ -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 diff --git a/src/Web/Geek/Type.hs b/src/Web/Geek/Type.hs --- a/src/Web/Geek/Type.hs +++ b/src/Web/Geek/Type.hs @@ -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)