Data.hs

{-# LANGUAGE NamedFieldPuns #-}
module Yesod.CoreBot.Bliki.Resources.Data where

import Yesod.CoreBot.Bliki.Prelude 

import Yesod.CoreBot.Bliki.Resources.Base 

import Yesod.CoreBot.Bliki.Cache.UpdateHTML
import Yesod.CoreBot.Bliki.Config
import Yesod.CoreBot.Bliki.DB
import Yesod.CoreBot.Bliki.Store

import Control.Monad.Reader hiding ( lift )
import Control.Monad.State.Strict hiding ( lift )

import qualified Data.FileStore as FileStore

import Data.Map ( Map )
import qualified Data.Map as Map

import qualified Data.Text               as T

import Data.Time.Clock
import Data.Time.Clock.POSIX

import System.Directory ( createDirectory
                        , doesDirectoryExist
                        , removeDirectoryRecursive 
                        )

-- XXX: should be a RWST
type DataM master a = StateT DB ( StateT Store (ReaderT ( Config master ) IO) ) a

process_revisions :: Yesod master => ( Config master, Store ) -> IORef DB -> [ Revision ] -> IO ()
process_revisions ( config, store ) db_ref rs = do
    db  <- readIORef db_ref
    let db_mod = execStateT (apply_revisions rs) db
    db' <- runReaderT ( evalStateT db_mod store ) config 
    writeIORef db_ref db'

apply_revisions :: Yesod master => [ Revision ] -> DataM master ()
apply_revisions [] = do
    return ()
apply_revisions [ r ] = do
    let new_updates = revision_to_updates r
    apply_updates new_updates
    modify $ \db -> db { raw_history = r : raw_history db }
    return ()
apply_revisions (r : r_prev : rs) = do
    apply_revisions ( r_prev : rs )
    let new_updates = revision_to_updates r
    apply_updates new_updates
    modify $ \db -> db { raw_history = r : raw_history db }
    return ()

apply_updates :: Yesod master => [ DataUpdate ] -> DataM master ()
apply_updates [] = do
    return ()
apply_updates ( u : us ) = do
    apply_updates us
    modify $ \db -> db { update_log = u : update_log db }
    f u 
    where 
        f ( Wibble _ ) = do
            return ()

        f ( Tweet _ _ ) = do
            return ()

        f ( BlogAdded update_rev_ID blog_str ) = do
            b <- add_bloggable $ UpdateBloggable blog_str update_rev_ID
            build_blog_HTML ( prev_bloggable b ) update_rev_ID blog_str

        f ( EntryAdded update_rev_ID update_entry_path ) = do
            revs <- gets latest_revisions
            let revs' = Map.insert update_entry_path update_rev_ID revs
            modify $ \db -> db { latest_revisions = revs' }
            b <- add_bloggable $ WikiBloggable update_entry_path update_rev_ID
            lift $ build_node_HTML (prev_bloggable b) update_rev_ID update_entry_path

        f ( EntryChanged update_rev_ID update_entry_path ) = do 
            revs <- gets latest_revisions
            let revs' = Map.insert update_entry_path update_rev_ID revs
            modify $ \db -> db { latest_revisions = revs' }
            bs <- gets bloggables
            b <- case bs of
                ( WikiBloggable blog_entry view_rev prev_bloggable : rest_bs )
                    | blog_entry == update_entry_path -> do
                        let b' = WikiBloggable blog_entry update_rev_ID prev_bloggable
                        modify $ \db -> db { bloggables = b' : rest_bs }
                        return b'
                _ -> do
                    add_bloggable $ WikiBloggable update_entry_path update_rev_ID 
            lift $ build_node_HTML ( prev_bloggable b ) update_rev_ID update_entry_path

add_bloggable :: ( Maybe Bloggable -> Bloggable ) -> DataM master Bloggable
add_bloggable fb = do
    bs <- gets bloggables
    let b = case bs of
                []         -> fb Nothing
                b_prev : _ -> fb $ Just b_prev
    modify $ \db -> db { bloggables = b : bs }
    return b

-- XXX: Should be event driven but that'd be harder
update_thread :: Yesod master => ( Config master, Store ) -> IORef DB  -> IO ()
update_thread ( config, store ) db_ref = do
    -- XXX: Lower bound to FileStore.history is not exclusive
    let inc_a_bit = addUTCTime (fromInteger 1)
    prev_time_ref <- newIORef =<< return . inc_a_bit =<< head_time db_ref
    let update_thread_ = do
            prev_time <- readIORef prev_time_ref
            putStrLn $ "probing for changes since " ++ show prev_time
            rs <- FileStore.history ( filestore store ) 
                                    [] 
                                    ( TimeRange (Just prev_time) 
                                                Nothing
                                    )
            case null rs of
                True -> return ()
                False -> do
                    putStrLn "found updates"
                    process_revisions ( config, store ) db_ref rs
                    writeIORef prev_time_ref =<< return . inc_a_bit 
                                             =<< head_time db_ref
            -- delay before probing for updates again
            threadDelay 10000000
    forever update_thread_

mk_data :: Yesod master => Config master -> IO ( Data_ master )
mk_data config = do
    -- clear memoization store
    should_clear_memo_store <- doesDirectoryExist $ cache_dir config
    when should_clear_memo_store $ removeDirectoryRecursive $ cache_dir config
    createDirectory $ cache_dir config
    -- build internal DB state
    let filestore = FileStore.gitFileStore $ store_dir config
        store = Store { filestore = filestore }
        empty_db = DB [] [] Map.empty []
    initial_history <- FileStore.history filestore [] (TimeRange Nothing Nothing) 
    let db_0_build = execStateT (apply_revisions initial_history) empty_db
    db_ref <- newIORef =<< runReaderT (evalStateT db_0_build store) config
    -- XXX: Only because store is not pure value but a reference
    the_ID <- forkIO $ update_thread ( config, store ) db_ref
    return Data { config            = config
                , store             = store
                , update_thread_ID  = the_ID
                , db_ref            = db_ref
                }

node_HTML_content :: Yesod master => Data_ master -> DB -> FilePath -> Content
node_HTML_content src_data db node_path = 
    let Just rev_ID = Map.lookup node_path ( latest_revisions db )
        out_path = node_HTML_path (config src_data) rev_ID node_path
    in ContentFile out_path Nothing

blog_HTML_content :: Yesod master => Data_ master -> RevisionId -> Content
blog_HTML_content src_data rev_ID = 
    let out_path = blog_HTML_path (config src_data) rev_ID
    in ContentFile out_path Nothing

getBlogR  :: Yesod master => RevisionId -> GHandler ( Data_ master ) master [(ContentType, Content)]
getBlogR rev_ID = do
    src_data <- getYesodSub
    let out_HTML_content = blog_HTML_content src_data rev_ID
    return [ ( typeHtml, out_HTML_content )
           ]
    
getLatestR :: Yesod master => GHandler ( Data_ master ) master [(ContentType, Content)]
getLatestR = do
    src_data <- getYesodSub 
    db <- liftIO $ readIORef $ db_ref src_data
    let latest = head $ bloggables db
    case latest of
        UpdateBloggable blog_str source_rev _ -> do
            let out_HTML = blog_HTML_content src_data source_rev
            return [ ( typeHtml, out_HTML )
                   , ( typePlain, toContent blog_str )
                   ]
        WikiBloggable blog_entry _ _  -> do
            let markdown_path = node_markdown_path (config src_data) blog_entry
            let out_HTML  = node_HTML_content src_data db blog_entry
            return [ ( typeHtml , out_HTML )
                   , ( typePlain, ContentFile markdown_path Nothing ) 
                   ]

getUpdateLogR :: Yesod master => GHandler ( Data_ master ) master RepJson
getUpdateLogR = do
    jsonToRepJson $ toJSON ()

getEntryRevR :: Yesod master 
             => RevisionId 
             -> [ Text ] 
             -> GHandler ( Data_ master ) master [(ContentType, Content)]
getEntryRevR rev_ID entry_path_texts = do
    src_data <- getYesodSub
    let ( first_path : rest_paths ) = map T.unpack entry_path_texts
        node_path = foldl (</>) first_path rest_paths
    let p = node_HTML_path (config src_data) rev_ID node_path
    let markdown_path = node_markdown_path (config src_data) node_path
    return [ ( typeHtml , ContentFile p Nothing  )
           , ( typePlain, ContentFile markdown_path Nothing ) 
           ]
    
getEntryLatestR :: Yesod master => [ Text ] -> GHandler ( Data_ master ) master [(ContentType, Content)]
getEntryLatestR entry_path_texts = do
    let ( first_path : rest_paths ) = map T.unpack entry_path_texts
        node_path = foldl (</>) first_path rest_paths
    src_data <- getYesodSub
    db <- liftIO $ readIORef $ db_ref src_data
    let x = Map.lookup node_path ( latest_revisions db )
    case x of
        Nothing -> do
            liftIO $ putStrLn $ "no node at path " ++ show node_path
            fail $ "no node at path " ++ show node_path
        Just rev_ID -> do
            liftIO $ putStrLn $ "latest rev of " ++ show node_path ++ " is " ++ show rev_ID
            getEntryRevR rev_ID entry_path_texts

mkYesodSubDispatch "Data_ master" [] [parseRoutes|
/latest                     LatestR      GET
/                           UpdateLogR   GET
/entry/*Texts               EntryLatestR GET
/blog/#RevisionId           BlogR        GET 
/rev/#RevisionId/*Texts     EntryRevR    GET
|]