diff --git a/geek.cabal b/geek.cabal --- a/geek.cabal +++ b/geek.cabal @@ -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 diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -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 ------------ diff --git a/src/MainDist.hs b/src/MainDist.hs deleted file mode 100644 --- a/src/MainDist.hs +++ /dev/null @@ -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 - 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 @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/Web/Geek/DefaultConfig.hs b/src/Web/Geek/DefaultConfig.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/DefaultConfig.hs @@ -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) diff --git a/src/Web/Geek/MarkupEngine/Markdown.hs b/src/Web/Geek/MarkupEngine/Markdown.hs deleted file mode 100644 --- a/src/Web/Geek/MarkupEngine/Markdown.hs +++ /dev/null @@ -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 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 @@ -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 === "

abc

" - + -} + it "should have tags" - do let _post = def {meta = [("tags", "haskell, blog")]} :: Post post_tags "tags" _post === ["haskell", "blog"] diff --git a/src/Web/Geek/Runtime.hs b/src/Web/Geek/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/Runtime.hs @@ -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 + } + + diff --git a/src/Web/Geek/ServeWithSnapServer.hs b/src/Web/Geek/ServeWithSnapServer.hs deleted file mode 100644 --- a/src/Web/Geek/ServeWithSnapServer.hs +++ /dev/null @@ -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