module Web.Geek.Runtime where
import Air.Data.Record.SimpleLabel hiding (get)
import Air.Env
import Air.Extra hiding (date)
import Control.Concurrent.Chan
import Control.Monad hiding (join)
import Data.Function (on)
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
import Web.Geek.Type
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.ICU as ICU
import qualified Data.Text.IO as TextIO
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
_ <- readChan events
time_stamp <- now
writeIORef last_event_time_stamp time_stamp
fork forever record_event
let
lazy_update = do
sleep (0.1 :: Double)
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
_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 ((++))
_full_text_search_map_ref <- newIORef _full_text_search_map
puts 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 :: Double)
return
def
{
posts_ref = _posts_ref
, markup_engines = _markup_engines
, config = _config
, full_text_search_map_ref = _full_text_search_map_ref
}
register_monitor :: WatchManager -> FilePath -> (FilePath -> IO ()) -> IO ()
register_monitor manager _path callback = do
watchTree manager (decodeString _path) (const True) (\event -> do
action event
)
where
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
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)