diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Nemesis b/Nemesis new file mode 100644 --- /dev/null +++ b/Nemesis @@ -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 () diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/geek.cabal b/geek.cabal new file mode 100644 --- /dev/null +++ b/geek.cabal @@ -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 +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 diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -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 +------ + + + + +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/MainDist.hs b/src/MainDist.hs new file mode 100644 --- /dev/null +++ b/src/MainDist.hs @@ -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 + diff --git a/src/Web/Geek/Application.hs b/src/Web/Geek/Application.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/Application.hs @@ -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) diff --git a/src/Web/Geek/Config.hs b/src/Web/Geek/Config.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/Config.hs @@ -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 + diff --git a/src/Web/Geek/DemoMiddlewareStack.hs b/src/Web/Geek/DemoMiddlewareStack.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/DemoMiddlewareStack.hs @@ -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) + ] diff --git a/src/Web/Geek/ImportFromBamboo.hs b/src/Web/Geek/ImportFromBamboo.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/ImportFromBamboo.hs @@ -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 () diff --git a/src/Web/Geek/MarkupEngine/Markdown.hs b/src/Web/Geek/MarkupEngine/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/MarkupEngine/Markdown.hs @@ -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 diff --git a/src/Web/Geek/Post.hs b/src/Web/Geek/Post.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/Post.hs @@ -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 === "

abc

" + + 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 diff --git a/src/Web/Geek/Serve.hs b/src/Web/Geek/Serve.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/Serve.hs @@ -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 + diff --git a/src/Web/Geek/ServeWithSnapServer.hs b/src/Web/Geek/ServeWithSnapServer.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/ServeWithSnapServer.hs @@ -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 diff --git a/src/Web/Geek/Spec.hs b/src/Web/Geek/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/Spec.hs @@ -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 + diff --git a/src/Web/Geek/Type.hs b/src/Web/Geek/Type.hs new file mode 100644 --- /dev/null +++ b/src/Web/Geek/Type.hs @@ -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