geek 1.0.0.8 → 1.0.0.9
raw patch · 13 files changed
+226/−187 lines, 13 files
Files
- Nemesis +11/−8
- geek.cabal +7/−7
- src/Web/Geek/Application.hs +72/−72
- src/Web/Geek/Config.hs +17/−14
- src/Web/Geek/DefaultConfig.hs +9/−6
- src/Web/Geek/DemoMiddlewareStack.hs +1/−0
- src/Web/Geek/ImportFromBamboo.hs +3/−1
- src/Web/Geek/Post.hs +4/−1
- src/Web/Geek/RSS.hs +21/−19
- src/Web/Geek/Runtime.hs +71/−57
- src/Web/Geek/Serve.hs +5/−1
- src/Web/Geek/Spec.hs +1/−0
- src/Web/Geek/Type.hs +4/−1
Nemesis view
@@ -4,23 +4,26 @@ import System.Nemesis.Titan main = run - do- + clean [ "**/*.o" , "**/*.hi" ]- - ++ desc "prepare cabal dist" task "dist" - do sh "cabal clean" sh "cabal configure" sh "cabal sdist"- + titan "Main.hs"- - ++ task "t:Main/titan" - return ()- - +++ desc "console"+ task "i" - do+ sh "ghci -isrc src/Web/Geek/Serve.hs"
geek.cabal view
@@ -1,5 +1,5 @@ Name: geek-Version: 1.0.0.8+Version: 1.0.0.9 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,13 +12,13 @@ Cabal-version: >= 1.6 category: Web homepage: http://github.com/nfjinjing/geek-data-files: +data-files: Nemesis , src/Web/Geek/ImportFromBamboo.hs- -Library - ghc-options: -Wall++Library+ ghc-options: -W build-depends: base >= 4 && < 99 , Glob , aeson@@ -50,9 +50,9 @@ , uuid , moe - + hs-source-dirs: src/- exposed-modules: + exposed-modules: Web.Geek.Application Web.Geek.Config Web.Geek.DefaultConfig
src/Web/Geek/Application.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE NoImplicitPrelude #-}++ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE NoImplicitPrelude #-} module Web.Geek.Application where@@ -48,52 +50,52 @@ initialize_geek :: Config -> [MarkupEngine] -> IO Application initialize_geek _config _markup_engines = do _runtime <- initialize_runtime _config _markup_engines- + let geek_app = geek _runtime - let - static_serve_stack = - _config.static_serve.toAscList.map (\(_root, _paths) -> - static + let+ static_serve_stack =+ _config.static_serve.toAscList.map (\(_root, _paths) ->+ static (Just - encodeUtf8 (T.pack - _config.blog_directory / _root.T.unpack)) (_paths.map encodeUtf8) ) - + _middleware = use static_serve_stack- + let _app = _middleware geek_app- + return _app - + geek :: Runtime -> Application-geek runtime = - let +geek runtime =+ let _config = runtime.config- + json x = Miku.json - l2s - encodePretty - toJSON x- + pager :: AppMonadT (Integer, Integer) pager = do _params <- ask ^ params -- io - puts - show _params- + let _drop = ( _params.lookup "drop" >>= B.unpack > readMay ).fromMaybe (0 :: Integer) let _take = ( _params.lookup "take" >>= B.unpack > readMay ). fromMaybe (_config.maximum_number_of_posts_per_page) _safe_take = min _take (_config.maximum_number_of_posts_per_page) -- io - puts - (printf "drop: %i, take: %i" _drop _take :: String) return (_drop, _safe_take)- + query_text :: AppMonadT Text query_text = do _params <- ask ^ params let _query_text = _params.(lookup "query" > fromMaybe "" > B.unpack > b2u > T.pack > T.strip)- + return _query_text- - ++ -- Miku stuff read_posts :: IO [Post]@@ -116,145 +118,143 @@ keys = _full_text_search_map.Map.keys - _matched_post_ids_for_tokens = _query_tokens.map (\_token -> - let + _matched_post_ids_for_tokens = _query_tokens.map (\_token ->+ let _matched_keys = keys.select (_token `T.isInfixOf`)- in + in _matched_keys.map (\k -> _full_text_search_map.Map.lookup k) .catMaybes .concat .unique ) _matched_post_ids_set_list = _matched_post_ids_for_tokens.map (Set.fromList) - matched_post_ids = + matched_post_ids = _matched_post_ids_set_list .inject (_matched_post_ids_set_list.Set.unions) Set.intersection .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 = + 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 + filter_posts_by_tag _posts _maybe_tag =+ case _maybe_tag of Nothing -> _posts Just _tag -> _posts.select (tags > has _tag) in- + miku - do get "/posts" - do _params <- ask ^ params- - ++ _maybe_tag <- text_params ^ lookup_non_empty_and_stripped "tag"- + _query_text <- query_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 clean_raw_body _post = _post .set __raw_body ""- + json- paginated_posts.map clean_raw_body- - ++ get "/posts/:year/:month/:day/:title" - do _captures <- text_captures posts <- io - read_posts- - let ++ let _post = fromMaybe def - do 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- + let post_date = def {utctDay = post_day}- + posts.find (\x -> x.date.is (Just post_date) && (ICU.compare [] (x.title) _title == EQ))- + json _post- - - +++ get "/tags" - do _query_text <- query_text- + _posts_filtered_by_query <- io - read_posts_by_query _query_text- + _posts <- io - read_posts- + 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- + sorted_tags = all_tags.Map.toAscList.map swap.rsort.map swap- + tag_data_list = sorted_tags.map (splat TagCount)- + json tag_data_list - - let ++ let rss_tag_controller :: AppMonadT () rss_tag_controller = do _posts <- io - read_posts- + _maybe_tag <- text_captures ^ lookup_non_empty_and_stripped "tag"- + let _posts_filtered_by_tag_and_query = filter_posts_by_tag _posts _maybe_tag- + text - rss _config (_posts_filtered_by_tag_and_query.take (_config.number_of_posts_per_feed)) _maybe_tag- + modify - set_content_type "text/xml"- + get "/rss.xml" - do rss_tag_controller- + get "/:tag/rss.xml" - do rss_tag_controller- + get "/tag/:tag/rss.xml" - do rss_tag_controller- - ++ -- for angular html5 mode get "*" - do- io - puts - "serving :" + _config.index_file_path.T.unpack- _response <- io - serve Nothing (_config.index_file_path.encodeUtf8) State.put _response- + modify - set_content_type "text/html"- +
src/Web/Geek/Config.hs view
@@ -1,8 +1,11 @@+{-# LANGUAGE NoImplicitPrelude #-}++ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-} + module Web.Geek.Config where import Air.Env hiding (mod)@@ -35,7 +38,7 @@ read_config_from_path :: FilePath -> IO (Maybe Config) read_config_from_path _path = do _config <- readProcess ("." / _path) [] ""- + return - _config.u2b.B.pack.parse_config @@ -51,15 +54,15 @@ get_config_from_args :: IO Config get_config_from_args = do let default_config_path = "blog/geek-config.hs"- + _args <- getArgs- - let ++ let usage = do puts geek_usage exitWith (ExitFailure 1)- - ++ _path <- case _args of [] -> return default_config_path@@ -69,18 +72,18 @@ usage _path_exist <- doesFileExist _path- - maybe_config <- ++ maybe_config <- if not _path_exist then do puts - printf "Warning: %s does not exist!" _path puts "" puts - "Fall back to Geek default configuration." return - parse_config (default_config_string.u2b.B.pack)- - else do ++ else do read_config_from_path _path- + case maybe_config of Nothing -> do puts - "Failed to parse the output of: " + _path@@ -90,9 +93,9 @@ puts "" puts default_config_string puts ""- + exitWith (ExitFailure 1)- + Just _config -> do puts "" TextIO.putStrLn - pretty_print_config _config
src/Web/Geek/DefaultConfig.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-}++ module Web.Geek.DefaultConfig where import Air.Env (def)@@ -20,7 +22,7 @@ , markup_engine_names = ["markdown"] , server_port = 3000 , static_serve = Map.fromList _static_serve- , maximum_number_of_posts_per_page = 20 + , 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@@ -30,11 +32,11 @@ , rss_site_root_prefix = "" } where- _static_serve = + _static_serve = [- ( + ( "angular/app"- , [ + , [ "/css" , "/img" , "/js"@@ -43,7 +45,7 @@ , "/index.html" ] )- + , ( "public" , [@@ -56,3 +58,4 @@ main :: IO () main = TextIO.putStrLn (pretty_print_config default_config)+
src/Web/Geek/DemoMiddlewareStack.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} + module Web.Geek.DemoMiddlewareStack where import Air.Env
src/Web/Geek/ImportFromBamboo.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE NoImplicitPrelude #-}+ module Web.Geek.ImportFromBamboo where
src/Web/Geek/Post.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE NoImplicitPrelude #-}++ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE NoImplicitPrelude #-}+ module Web.Geek.Post where
src/Web/Geek/RSS.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE NoImplicitPrelude #-}++ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE NoImplicitPrelude #-} module Web.Geek.RSS (rss) where@@ -24,7 +26,7 @@ import Data.Char (isSpace) {-- + <?xml version="1.0" encoding="UTF-8"?> <rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom"> <channel>@@ -43,12 +45,12 @@ {% endfor %} </channel> </rss>- + <link rel="alternate" type="application/rss+xml" title="{{ site.name }}" href="{{ site.url }}/rss.xml">- + -} --- xml_header +-- xml_header xml_header :: MoeUnit xml_header = no_escape_no_indent_str "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" @@ -58,50 +60,50 @@ rss :: Geek.Config -> [Geek.Post] -> Maybe Text -> ByteString rss _config _posts _maybe_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- site_link_with_prefix = + site_link_with_prefix = ( [ site_link , _config.Geek.rss_site_root_prefix.T.unpack.drop_tail_slash.reverse.drop_tail_slash ] ).reject (all isSpace).join "/"- + 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_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_with_prefix + "/" + _post.Geek.link.Geek.unURIEscapedText.T.unpack element "link" - do str - post_link element "guid" ! [attr "isPermaLink" "true"] - do str - post_link- - ++
src/Web/Geek/Runtime.hs view
@@ -1,8 +1,12 @@+{-# LANGUAGE NoImplicitPrelude #-}++ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE NoImplicitPrelude #-} ++ module Web.Geek.Runtime where import Air.Data.Record.SimpleLabel hiding (get)@@ -34,25 +38,25 @@ build_markup_engines :: [Text] -> [MarkupEngine] -> [MarkupEngine]-build_markup_engines user_markup_engine_names _markup_engines = +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- + content <- TextIO.readFile _path- + let (_title, _date) = parse_title_and_date_from_path (_config.post_date_format) _path (_meta, _raw_body) = parse_meta (content) _body = markup _markup_engines _path _raw_body- - _raw_body_for_search = ++ _raw_body_for_search = if (_config.full_text_search) then _raw_body else def- + _post = def { title = _title@@ -62,11 +66,11 @@ , meta = _meta , raw_body = _raw_body_for_search }- + _link = post_link _post- _tags = post_tags _meta_tag_keyword _post - - return - + _tags = post_tags _meta_tag_keyword _post++ return - _post .set __link _link .set __tags _tags@@ -78,97 +82,107 @@ get_posts _config _markup_engines = do putStr - "Loading Posts ... " post_paths <- glob_dir "*" (_config.blog_directory / _config.post_directory)- + posts <- forM post_paths - get_post_from_path _config _markup_engines puts - "Done!" 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 -> [MarkupEngine] -> Chan Event -> IORef [Post] -> IORef (Map.Map Text [Int]) -> IO ()+monitor_posts _config _markup_engines events _posts_ref _full_text_search_map_ref = do last_event_time_stamp <- now >>= newIORef last_update_time_stamp <- now >>= newIORef- + let record_event = do _ <- readChan events -- printf "Caught: %s\n" - show e time_stamp <- now- + writeIORef last_event_time_stamp time_stamp- + fork - forever record_event- + let lazy_update = do 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+ update_full_text_search_map _config _posts_ref _full_text_search_map_ref now >>= writeIORef last_update_time_stamp- + else return ()- + forever lazy_update -initialize_runtime :: Config -> [MarkupEngine] -> IO Runtime-initialize_runtime _config app_markups_engines = do- - let _markup_engines = build_markup_engines (_config.markup_engine_names) app_markups_engines- - -- puts - "markup engine length: " + _markup_engines.length.show- _posts <- get_posts _config _markup_engines- _posts_ref <- newIORef _posts- - let +update_full_text_search_map :: Config -> IORef [Post] -> IORef (Map.Map Text [Int]) -> IO ()+update_full_text_search_map _config _posts_ref _full_text_search_map_ref = do+ _posts <- readIORef _posts_ref+ -- puts "Building full text search database ..."++ let _full_text_search_map = if not - _config.full_text_search then def else zip [0,1..] _posts- .map ((\(_id, _post) -> + .map ((\(_id, _post) -> let _full_text = _post.title + " " + _post.raw_body in zip (_full_text.ICU.toLower ICU.Current .T.words) (repeat [_id]) )) .concat .Map.fromListWith ((++))- - -- puts "Building full text search database ..." - _full_text_search_map_ref <- newIORef _full_text_search_map- + -- print - _full_text_search_map.Map.toAscList.take 50- puts - printf "Search database has %i unique keywords." (_full_text_search_map.Map.size)- ++ writeIORef _full_text_search_map_ref _full_text_search_map++initialize_runtime :: Config -> [MarkupEngine] -> IO Runtime+initialize_runtime _config app_markups_engines = do++ let _markup_engines = build_markup_engines (_config.markup_engine_names) app_markups_engines++ -- puts - "markup engine length: " + _markup_engines.length.show+ _posts <- get_posts _config _markup_engines+ _posts_ref <- newIORef _posts++ _full_text_search_map_ref <- newIORef def++ update_full_text_search_map _config _posts_ref _full_text_search_map_ref+++ 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 _full_text_search_map_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 :: Double)- - return - - def - { ++ return -+ def+ { posts_ref = _posts_ref , markup_engines = _markup_engines , config = _config , full_text_search_map_ref = _full_text_search_map_ref } -register_monitor :: WatchManager -> FilePath -> (FilePath -> IO ()) -> IO ()+register_monitor :: WatchManager -> FilePath -> (FilePath -> IO ()) -> IO StopListening 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@@ -184,27 +198,27 @@ 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 - + writeChan path_chan file_path+ let test_case_id = "callback" test_case_path = test_path / test_case_id @@ -212,8 +226,8 @@ 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)
src/Web/Geek/Serve.hs view
@@ -1,7 +1,11 @@+{-# LANGUAGE NoImplicitPrelude #-}++ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE NoImplicitPrelude #-}++ module Web.Geek.Serve where
src/Web/Geek/Spec.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} + module Web.Geek.Spec where import Test.Hspec
src/Web/Geek/Type.hs view
@@ -1,8 +1,11 @@+{-# LANGUAGE NoImplicitPrelude #-}++ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE NoImplicitPrelude #-}+ module Web.Geek.Type where