geek 1.0.0.1 → 1.0.0.3
raw patch · 10 files changed
+254/−116 lines, 10 filesdep −hack2-handler-snap-serverdep −pandocdep ~airdep ~air-extradep ~hack2-contrib
Dependencies removed: hack2-handler-snap-server, pandoc
Dependency ranges changed: air, air-extra, hack2-contrib
Files
- geek.cabal +5/−44
- readme.md +6/−6
- src/MainDist.hs +0/−10
- src/Web/Geek/Application.hs +0/−1
- src/Web/Geek/Config.hs +0/−1
- src/Web/Geek/DefaultConfig.hs +53/−0
- src/Web/Geek/MarkupEngine/Markdown.hs +0/−31
- src/Web/Geek/Post.hs +3/−2
- src/Web/Geek/Runtime.hs +187/−0
- src/Web/Geek/ServeWithSnapServer.hs +0/−21
geek.cabal view
@@ -1,5 +1,5 @@ Name: geek-Version: 1.0.0.1+Version: 1.0.0.3 Build-type: Simple Synopsis: Geek blog engine Description: A dynamic blog engine, customizable with standard web technology, i.e. HTML, CSS and Javascript (JSON)@@ -23,8 +23,8 @@ , Glob , aeson , aeson-pretty- , air >= 2013.7.15- , air-extra+ , air >= 2013.7.18+ , air-extra >= 2013.7.18 , air-spec , bytestring , containers@@ -35,12 +35,10 @@ , fsnotify , hack2 , hack2-contrib- , hack2-handler-snap-server , hspec , miku , mtl , old-locale- , pandoc , process , random , safe@@ -56,47 +54,10 @@ exposed-modules: Web.Geek.Application Web.Geek.Config+ Web.Geek.DefaultConfig Web.Geek.DemoMiddlewareStack- Web.Geek.MarkupEngine.Markdown Web.Geek.Post Web.Geek.Serve- Web.Geek.ServeWithSnapServer Web.Geek.Spec Web.Geek.Type---Executable geek- ghc-options: -threaded- build-depends: base >= 4 && < 99- , Glob- , aeson- , aeson-pretty- , air- , air-extra- , air-spec- , bytestring- , containers- , data-default- , directory- , filepath- , fsnotify- , hack2- , hack2-contrib >= 2013.7.17- , hack2-handler-snap-server- , hspec- , miku- , mtl- , old-locale- , pandoc- , random- , safe- , split- , system-filepath- , text- , text-icu- , time- , uuid-- - hs-source-dirs: src/- main-is: MainDist.hs+ Web.Geek.Runtime
readme.md view
@@ -9,14 +9,14 @@ * Write posts in Markdown * Full text search * Layout is configurable through HTML, CSS and Javascript-* [Jekyll's front matter] compatible+* [Jekyll's front matter](http://jekyllrb.com/docs/frontmatter/) compatible Installation ------------ ### Install Geek - cabal install geek+ cabal install geek-server ### Get a Geek Blog Seed @@ -41,10 +41,10 @@ ### 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`+* 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 ------------
− src/MainDist.hs
@@ -1,10 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Main where--import Air.Env-import Web.Geek.ServeWithSnapServer (serve_with_snap_server)--main :: IO ()-main = serve_with_snap_server-
src/Web/Geek/Application.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-}
src/Web/Geek/Config.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}
+ src/Web/Geek/DefaultConfig.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Web.Geek.DefaultConfig where++import Air.Env (def)+import Prelude (Bool(..), IO)+import qualified Data.Map as Map+import Web.Geek.Type (Config(..), pretty_print_config)+import qualified Data.Text.IO as TextIO (putStrLn)++default_config :: Config+default_config = def+ {+ blog_directory = "blog"+ , post_directory = "posts"+ , post_date_format = "%Y-%m-%d-"+ , meta_tag_keyword = "categories"+ , meta_date_keyword = "date"+ , markup_engine_names = ["markdown"]+ , server_port = 3000+ , static_serve = Map.fromList _static_serve+ , maximum_number_of_posts_per_page = 20 + , index_file_path = "blog/angular/app/index.html"+ , full_text_search = True+ }+ where+ _static_serve = + [+ ( + "angular/app"+ , [ + "/css"+ , "/img"+ , "/js"+ , "/lib"+ , "/partials"+ , "/index.html"+ ]+ )+ + , (+ "public"+ , [+ "/download"+ , "/images"+ , "/media"+ ]+ )+ ]++main :: IO ()+main = TextIO.putStrLn (pretty_print_config default_config)
− src/Web/Geek/MarkupEngine/Markdown.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE NoImplicitPrelude #-}---module Web.Geek.MarkupEngine.Markdown where--import Air.Env-import Air.TH-import Data.Text (Text, pack, unpack)-import GHC.Exts( IsString(..) )-import Test.Hspec-import Text.Pandoc (readMarkdown, writeHtmlString)-import Web.Geek.Type-import qualified Data.ByteString.Char8 as B-import qualified Data.Default as Default--markdown :: MarkupEngine-markdown = def- {- markup_engine_name = "markdown"- , extensions = ["md", "markdown"]- , transformer = _transformer- }- where- _transformer = - unpack- > readMarkdown Default.def- > writeHtmlString Default.def- > fromString
src/Web/Geek/Post.hs view
@@ -21,7 +21,6 @@ import System.Locale import Test.Hspec import Web.Geek.Config-import Web.Geek.MarkupEngine.Markdown import Web.Geek.Type import qualified Data.ByteString.Char8 as B import qualified Data.Text as T@@ -120,11 +119,13 @@ parse_title_and_date_from_path "%Y-%m-%d-" path === title_and_date + {- it "should markup" - do let path = "blog/posts/2010-10-30-dummy title.md" body = "### abc" markup [markdown] path body === "<h3 id=\"abc\">abc</h3>"-+ -}+ it "should have tags" - do let _post = def {meta = [("tags", "haskell, blog")]} :: Post post_tags "tags" _post === ["haskell", "blog"]
+ src/Web/Geek/Runtime.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Web.Geek.Runtime where++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 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.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+ + 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 = + if (_config.full_text_search)+ then _raw_body+ else def+ + _post = def+ {+ title = _title+ , date = _date+ , path = _path+ , body = _body+ , meta = _meta+ , raw_body = _raw_body_for_search+ }+ + _link = post_link _post+ _tags = post_tags _meta_tag_keyword _post + + return - + _post+ .set __link _link+ .set __tags _tags++glob_dir :: String -> FilePath -> IO [String]+glob_dir pattern path = globDir1 (compile pattern) path++get_posts :: Config -> [MarkupEngine] -> IO [Post]+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+ last_event_time_stamp <- now >>= newIORef+ last_update_time_stamp <- now >>= newIORef+ + let+ record_event = do+ e <- 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+ 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+ 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 + _full_text_search_map =+ if not - _config.full_text_search+ then+ def+ else+ zip [0,1..] _posts+ .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+ + 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++ 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+ + return - + def + { + posts_ref = _posts_ref+ , markup_engines = _markup_engines+ , config = _config+ , full_text_search_map_ref = _full_text_search_map_ref+ }++
− src/Web/Geek/ServeWithSnapServer.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Web.Geek.ServeWithSnapServer where--import Air.Env-import Hack2-import Hack2.Contrib.Utils (use)-import Hack2.Handler.SnapServer-import Web.Geek.DemoMiddlewareStack-import Web.Geek.MarkupEngine.Markdown-import Web.Geek.Serve (serve)-import qualified Data.Default as Default--serve_with_snap_server :: IO ()-serve_with_snap_server = - let- server_backend _app _port =- runWithConfig Default.def {port = _port} _app- in- - serve [markdown] demo_middleware_stack server_backend