geek (empty) → 1.0.0.1
raw patch · 16 files changed
+1171/−0 lines, 16 filesdep +Globdep +aesondep +aeson-prettysetup-changed
Dependencies added: Glob, aeson, aeson-pretty, air, air-extra, air-spec, base, bytestring, containers, curl, data-default, directory, filepath, fsnotify, hack2, hack2-contrib, hack2-handler-snap-server, hspec, miku, mtl, old-locale, pandoc, process, random, safe, split, system-filepath, text, text-icu, time, uuid
Files
- LICENSE +31/−0
- Nemesis +24/−0
- Setup.hs +2/−0
- geek.cabal +102/−0
- readme.md +53/−0
- src/MainDist.hs +10/−0
- src/Web/Geek/Application.hs +321/−0
- src/Web/Geek/Config.hs +117/−0
- src/Web/Geek/DemoMiddlewareStack.hs +27/−0
- src/Web/Geek/ImportFromBamboo.hs +118/−0
- src/Web/Geek/MarkupEngine/Markdown.hs +31/−0
- src/Web/Geek/Post.hs +135/−0
- src/Web/Geek/Serve.hs +28/−0
- src/Web/Geek/ServeWithSnapServer.hs +21/−0
- src/Web/Geek/Spec.hs +13/−0
- src/Web/Geek/Type.hs +138/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2013, Jinjing Wang++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jinjing Wang nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Nemesis view
@@ -0,0 +1,24 @@+import Air.Env+import Prelude ()+import System.Nemesis.Env+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 ()
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ geek.cabal view
@@ -0,0 +1,102 @@+Name: geek+Version: 1.0.0.1+Build-type: Simple+Synopsis: Geek blog engine+Description: A dynamic blog engine, customizable with standard web technology, i.e. HTML, CSS and Javascript (JSON)++License: BSD3+License-file: LICENSE+Author: Jinjing Wang+Maintainer: Jinjing Wang <nfjinjing@gmail.com>+Build-Depends: base+Cabal-version: >= 1.6+category: Web+homepage: http://github.com/nfjinjing/geek+data-files: readme.md+ , Nemesis+ , src/Web/Geek/ImportFromBamboo.hs+ ++Library + ghc-options: -Wall+ build-depends: base >= 4 && < 99+ , Glob+ , aeson+ , aeson-pretty+ , air >= 2013.7.15+ , air-extra+ , air-spec+ , bytestring+ , containers+ , curl+ , data-default+ , directory+ , filepath+ , fsnotify+ , hack2+ , hack2-contrib+ , hack2-handler-snap-server+ , hspec+ , miku+ , mtl+ , old-locale+ , pandoc+ , process+ , random+ , safe+ , split+ , system-filepath+ , text+ , text-icu+ , time+ , uuid++ + hs-source-dirs: src/+ exposed-modules: + Web.Geek.Application+ Web.Geek.Config+ 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
+ readme.md view
@@ -0,0 +1,53 @@+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] compatible++Installation+------------++### Install Geek++ cabal install geek++### 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
+ src/MainDist.hs view
@@ -0,0 +1,10 @@+{-# 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
@@ -0,0 +1,321 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}+++module Web.Geek.Application 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.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.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 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 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 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+++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 + (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 + _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 :: AppMonadT [Post]+ read_posts = io - readIORef - runtime.posts_ref++ filter_posts_by_query :: Text -> AppMonadT [Post]+ filter_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++ let _lowered_query_text = ICU.toLower ICU.Current _query_text++ _number_of_maximum_tokens = 7++ _query_tokens = _lowered_query_text.T.words.take _number_of_maximum_tokens++ keys = _full_text_search_map.Map.keys+++ _matched_post_ids_for_tokens = _query_tokens.map (\_token -> + let + _matched_keys = keys.select (_token `T.isInfixOf`)+ 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_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+ in+ + miku - do+ get "/posts" - do+ _params <- ask ^ params+ + + let tag_string = _params.(lookup "tag" > fromMaybe "" > B.unpack > b2u)+ tag_text = tag_string.T.pack.T.strip+ + + _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)+ + (_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 ""+ + json- paginated_posts.map clean_raw_body+ + + get "/posts/:year/:month/:day/:title" - do+ _captures <- captures++ posts <- 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+ + 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 <- filter_posts_by_query _query_text+ + _posts <- 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)+ + -- io - print tag_data_list+ json tag_data_list++ get "/" - do+ -- modify - redirect "/index.html" Nothing++ _response <- io - serve Nothing (_config.index_file_path.encodeUtf8)++ 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+ + 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+ 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/Config.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++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 Data.Aeson.Encode.Pretty (encodePretty)+import Data.Aeson.Generic (encode, decode)+import Data.Aeson.Generic (toJSON)+import Data.IORef+import Data.Text (Text)+import Data.Time+import System.Directory (doesFileExist, makeRelativeToCurrentDirectory)+import System.Environment (getArgs)+import System.Exit (exitWith, ExitCode(..))+import System.FSNotify+import System.Locale+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)+++default_config_string :: String+default_config_string = b2u - B.unpack - l2s - encodePretty - toJSON default_config++parse_config :: B.ByteString -> Maybe Config+parse_config = s2l > decode++read_config_from_path :: FilePath -> IO (Maybe Config)+read_config_from_path path = do+ config <- readProcess ("." / path) [] ""+ + return - config.u2b.B.pack.parse_config++++geek_usage :: String+geek_usage = [here|++ Usage: geek $GEEK_CONFIG_GENERATOR (default: geek-config.hs)++|]+++get_config_from_args :: IO Config+get_config_from_args = do+ let default_config_path = "geek-config"+ + _args <- getArgs+ + let + usage = do+ puts geek_usage+ exitWith (ExitFailure 1)+ + + _path <-+ case _args of+ [] -> return default_config_path+ [x] -> return x+ _ -> do+ puts - "Invalid number of arguments: " + show _args+ usage++ _path_exist <- doesFileExist _path+ + 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 + read_config_from_path _path+ + case maybe_config of+ Nothing -> do+ puts - "Failed to parse the output of: " + _path+ puts ""+ puts - "Example:"+ puts - 20.times '-'+ puts ""+ puts default_config_string+ puts ""+ + exitWith (ExitFailure 1)+ + Just _config -> do+ puts ""+ TextIO.putStrLn - pretty_print_config _config+ puts ""+ return _config+++post_date_length :: String -> Integer+post_date_length format = length - formatTime defaultTimeLocale format (def :: UTCTime)++spec :: Spec+spec = do+ describe "Config" - do+ it "should get date length" - do+ post_date_length "%Y-%m-%d-" === 11+
+ src/Web/Geek/DemoMiddlewareStack.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Web.Geek.DemoMiddlewareStack where++import Air.Env+import Data.Map (toAscList)+import Hack2+import Hack2.Contrib.Middleware.BounceFavicon (bounce_favicon) +import Hack2.Contrib.Middleware.SimpleAccessLogger (simple_access_logger)+import Hack2.Contrib.Middleware.UserMime (user_mime)+import Hack2.Contrib.Middleware.XForwardedForToRemoteHost (x_forwarded_for_to_remote_host)+import Hack2.Contrib.Mime++debug :: Middleware+debug app env = do+ puts - show env+ app env++demo_middleware_stack :: [Middleware]+demo_middleware_stack = + [+ bounce_favicon+ , x_forwarded_for_to_remote_host+ -- , debug+ , simple_access_logger Nothing+ , user_mime (mime_types.toAscList)+ ]
+ src/Web/Geek/ImportFromBamboo.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Web.Geek.ImportFromBamboo 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)+import Data.Aeson.Generic (encode)+import Data.Function (on)+import Data.IORef+import Data.List (find)+import Data.List (sortBy)+import Data.Maybe (fromMaybe, catMaybes)+import Data.Text (Text)+import Data.Time (formatTime, fromGregorianValid, UTCTime(..))+import Data.UUID (toString)+import Filesystem.Path.CurrentOS (encodeString, decodeString)+import Hack2 (Application)+import Hack2.Contrib.Middleware.Static+import Hack2.Contrib.Utils (use, unescape_uri)+import Network.Curl+import Network.Miku+import Safe+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.Application+import Web.Geek.Config+import Web.Geek.DefaultConfig+import Web.Geek.MarkupEngine.Markdown+import Web.Geek.Post+import Web.Geek.Type+import qualified Data.ByteString.Char8 as B+import qualified Data.Default as Default+import qualified Data.Text as T+import qualified Data.Text.IO as TextIO+import qualified Prelude as P++++{-++Description:++convert bamboo tag file format into front_matter style embeded format++Requiements:++put bamboo `blog` directory inside current directory+rename `blog/blog` to `blog/posts`+create a new empty directory `blog/posts2`++then run `get_post_from_path` from ghci++-}++import Web.Geek.Config+import Web.Geek.Runtime+ +convert_tags_from_bamboo :: IO ()+convert_tags_from_bamboo = do+ let + _meta_tag_keyword = _config.meta_tag_keyword+ _config = default_config+ _posts <- get_posts _config [markdown]+ + tags <- getDirectoryContents "blog/tag" ^ reject (belongs_to [".", ".."])+ + tag_map <- tags.mapM (\tag -> TextIO.readFile - "blog/tag" / tag)+ + + + -- puts - printf "tags: %s" - show tag_map+ + let + find_tag post =+ zip tags tag_map.map (\(tag_name, tag_content) ->+ if post.title `T.isInfixOf` tag_content+ then+ Just tag_name+ else+ Nothing+ )+ .catMaybes+ + forM_ _posts - \_post -> do+ let _title = _post.title.T.unpack+ if _post.meta.is []+ then+ case _post.find_tag of+ [] ->+ -- puts - printf "no tags found for %s" - _title+ return ()+ _tags -> do+ -- puts - printf "found tags: %s for %s" (show _tags) _title+ + let front_matter = "---\ncategories: " + _tags.join ", ".T.pack + "\n---\n\n"+ + _body <- TextIO.readFile - _post.path+ + let _export_path = "blog/posts2/" + _post.path.takeBaseName + ".md"+ puts - "exporting: " + _export_path+ TextIO.writeFile _export_path - front_matter + _body+ else+ -- puts - printf "%s has front_matter already" _title+ return ()
+ src/Web/Geek/MarkupEngine/Markdown.hs view
@@ -0,0 +1,31 @@+{-# 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
@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}++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.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.MarkupEngine.Markdown+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+ Nothing -> []+ Just s -> s.T.splitOn ",".map T.strip++post_link :: Post -> URIEscapedText+post_link post = + let + text_link =+ case post.date of+ Just _date -> + let+ link_format = "%Y/%m/%d"+ prefix = T.pack - formatTime defaultTimeLocale link_format - _date.utctDay+ in+ prefix + "/" + post.title+ Nothing ->+ "post/" + post.title+ in+ + text_link.T.unpack.fromString.URIEscapedText++parse_title_and_date_from_path :: String -> FilePath -> (T.Text, Maybe UTCTime)+parse_title_and_date_from_path post_date_format path = + let+ 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+ in+ (title.T.pack, date)+ +markup :: [MarkupEngine] -> FilePath -> Text -> HTMLText+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++parse_meta :: Text -> (Meta, Text)+parse_meta str = + let no_meta = ([], str)+ in+ + case str.T.stripStart.T.splitOn "---\n" of+ (x:y:zs) -> + if x.T.all isSpace + then+ let + parse_line line =+ case line.T.splitOn ":" of+ w1:w2:[] -> Just (w1.strip, w2.strip)+ _ -> Nothing+ in+ + let meta = y.T.lines.reject (T.all isSpace).map parse_line.catMaybes+ in+ (meta, zs.T.unlines.stripStart)+ else+ no_meta+ _ -> no_meta+++-- Spec++test_meta :: T.Text+test_meta = T.pack [here|++---+layout: post+categories: 日常+---++some thing++|]++spec :: Spec+spec = do+ describe "Post" - do+ it "should parse meta data" - do+ 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"+ 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+ + 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"]+ + it "should encode json" - do+ let _post = def {meta = [("tags", "haskell, blog")]} :: Post+ + _post.encode.decode === Just _post
+ src/Web/Geek/Serve.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Web.Geek.Serve where++import Air.Env+import Air.Extra hiding (date)+import Hack2+import Hack2.Contrib.Utils (use, unescape_uri)+import Web.Geek.Application+import Web.Geek.Config (get_config_from_args)+import Web.Geek.Type++type Port = Int++serve :: [MarkupEngine] -> [Middleware] -> (Application -> Port -> IO ()) -> IO ()+serve markup_engines middleware_stack server_backend = do+ _config <- get_config_from_args+ geek_app <- initialize_geek _config markup_engines+ + let _middleware = use middleware_stack+ _app = _middleware geek_app+ _port = _config.server_port+ + server_backend _app _port+
+ src/Web/Geek/ServeWithSnapServer.hs view
@@ -0,0 +1,21 @@+{-# 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
+ src/Web/Geek/Spec.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Web.Geek.Spec where++import Test.Hspec+import qualified Web.Geek.Post as Post+import qualified Web.Geek.Config as Config++spec :: Spec+spec = do+ Post.spec+ Config.spec+
+ src/Web/Geek/Type.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoImplicitPrelude #-}++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)++type Meta = [(Text, Text)]++newtype HTMLText = + HTMLText {unHTMLText :: Text}+ deriving (Show, Eq, Data, Typeable)++instance IsString HTMLText where+ fromString = escape_xml > pack > HTMLText+ +instance Default HTMLText where+ def = HTMLText def+ + +newtype URIEscapedText = + URIEscapedText {unURIEscapedText :: Text}+ deriving (Show, Eq, Data, Typeable)++instance IsString URIEscapedText where+ fromString = escape_uri > pack > URIEscapedText+ +instance Default URIEscapedText where+ def = URIEscapedText def++data Post = Post+ {+ title :: Text+ , path :: FilePath+ , meta :: Meta+ , date :: Maybe UTCTime+ , body :: HTMLText -- body must be HTML encoded+ , raw_body :: Text+ , link :: URIEscapedText+ , tags :: [Text]+ }+ deriving (Show, Eq, Data, Typeable)++mkDefault ''Post+mkLabel ''Post+++data MarkupEngine = MarkupEngine+ {+ markup_engine_name :: Text+ , extensions :: [Text]+ , transformer :: Text -> HTMLText+ }++instance Default MarkupEngine where+ def = MarkupEngine+ {+ markup_engine_name = "plain"+ , extensions = []+ , transformer = unpack > fromString+ }++instance Show MarkupEngine where+ show a = printf "MarkupEngine for: %s" (a.extensions.map unpack.join ", ")+++data Config = Config+ {+ blog_directory :: FilePath+ , post_directory :: FilePath+ , post_date_format :: String+ , markup_engine_names :: [Text]+ , meta_tag_keyword :: Text+ , meta_date_keyword :: Text+ , server_port :: Int+ , static_serve :: Map Text [Text]+ , maximum_number_of_posts_per_page :: Integer+ , index_file_path :: Text+ , full_text_search :: Bool+ }+ deriving (Show, Data, Typeable)+++mkDefault ''Config+mkLabel ''Config++pretty_print_config :: Config -> Text+pretty_print_config x = decodeUtf8 - l2s - encodePretty - toJSON x++data Runtime = Runtime+ {+ posts_ref :: IORef [Post]+ , markup_engines :: [MarkupEngine]+ , config :: Config+ , full_text_search_map_ref :: IORef (Map Text [Int])+ }++instance Default Runtime where+ def = Runtime+ { + posts_ref = undefined+ , markup_engines = []+ , config = def+ , full_text_search_map_ref = undefined+ }+ +data TagCount = TagCount+ {+ tag_name :: Text+ , tag_count :: Integer+ }+ deriving (Show, Data, Typeable)++mkDefault ''TagCount