diff --git a/geek.cabal b/geek.cabal --- a/geek.cabal +++ b/geek.cabal @@ -1,5 +1,5 @@ Name: geek -Version: 1.0.0.9 +Version: 1.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) @@ -14,9 +14,7 @@ homepage: http://github.com/nfjinjing/geek data-files: Nemesis - , src/Web/Geek/ImportFromBamboo.hs - Library ghc-options: -W build-depends: base >= 4 && < 99 @@ -35,19 +33,16 @@ , fsnotify , hack2 , hack2-contrib - , hspec , miku , mtl , old-locale , process , random , safe - , split , system-filepath , text , text-icu , time - , uuid , moe @@ -61,5 +56,4 @@ Web.Geek.RSS Web.Geek.Runtime Web.Geek.Serve - Web.Geek.Spec Web.Geek.Type 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 @@ -20,7 +20,7 @@ import System.Environment (getArgs) import System.Exit (exitWith, ExitCode(..)) import System.Locale (defaultTimeLocale) -import Test.Hspec + import Text.Printf import Web.Geek.DefaultConfig import Web.Geek.Type @@ -105,10 +105,3 @@ 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/ImportFromBamboo.hs b/src/Web/Geek/ImportFromBamboo.hs deleted file mode 100644 --- a/src/Web/Geek/ImportFromBamboo.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} - - -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/Post.hs b/src/Web/Geek/Post.hs --- a/src/Web/Geek/Post.hs +++ b/src/Web/Geek/Post.hs @@ -19,24 +19,23 @@ import GHC.Exts( IsString(..) ) import System.FilePath import System.Locale -import Test.Hspec import Web.Geek.Config import Web.Geek.Type import qualified Data.Text as T import qualified Data.Map as Map post_tags :: Text -> Post -> [Text] -post_tags _meta_tag_keyword post = +post_tags _meta_tag_keyword post = case post.meta.Map.lookup _meta_tag_keyword of Nothing -> [] Just s -> s.T.splitOn ",".map T.strip post_link :: Post -> URIEscapedText -post_link post = - let +post_link post = + let text_link = case post.date of - Just _date -> + Just _date -> let link_format = "%Y/%m/%d" prefix = T.pack - formatTime defaultTimeLocale link_format - _date.utctDay @@ -45,91 +44,48 @@ Nothing -> "post/" + post.title in - + text_link.T.unpack.fromString parse_title_and_date_from_path :: String -> FilePath -> (T.Text, Maybe UTCTime) -parse_title_and_date_from_path _post_date_format _path = +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 = +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 = +parse_meta str = let no_meta = (def, str) in - + case str.T.stripStart.T.splitOn "---\n" of - (x:y:zs) -> - if x.T.all isSpace + (x:y:zs) -> + if x.T.all isSpace then - let + 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 .to_h 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", "日常")].to_h, "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")].to_h} :: Post - post_tags "tags" _post === ["haskell", "blog"] - - it "should encode json" - do - let _post = def {meta = [("tags", "haskell, blog")].to_h} :: Post - - _post.encode.decode === Just _post diff --git a/src/Web/Geek/Runtime.hs b/src/Web/Geek/Runtime.hs --- a/src/Web/Geek/Runtime.hs +++ b/src/Web/Geek/Runtime.hs @@ -18,13 +18,11 @@ import Data.IORef import Data.List (sortBy) import Data.Text (Text) -import Data.UUID (toString) import Filesystem.Path.CurrentOS (encodeString, decodeString) import System.Directory import System.FSNotify import System.FilePath.Glob import System.Random -import Test.Hspec import Text.Printf import Web.Geek.DefaultConfig import Web.Geek.Post @@ -191,43 +189,3 @@ action (Added _path _) = callback - encodeString _path action (Modified _path _) = callback - encodeString _path action (Removed _path _) = callback - encodeString _path - - - -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 :: 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) diff --git a/src/Web/Geek/Spec.hs b/src/Web/Geek/Spec.hs deleted file mode 100644 --- a/src/Web/Geek/Spec.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# 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 -