module Web.RBB.Blog
( withBlog
, blogEntries
, Blog
, getBlogConfig
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Data.IxSet (toList)
import Data.List (sortBy)
import qualified Data.Map as Map
import Data.Time
import System.Exit (exitFailure)
import System.IO
import Web.RBB.Blog.Query
import Web.RBB.Config
import Web.RBB.Converter (renderEntries)
import Web.RBB.Crawler
import Web.RBB.Types.Blog hiding (Blog)
import qualified Web.RBB.Types.Blog as Internal
import Web.RBB.Types.CachedEntry
import Web.RBB.Types.Entry
import Web.RBB.Util
newtype Blog m = Blog (Maybe (TVar (Internal.Blog m)))
getBlogConfig :: (Functor io, MonadIO io)
=> Blog m -> io (Maybe (BlogConfig m))
getBlogConfig (Blog Nothing) = return Nothing
getBlogConfig (Blog (Just blog)) = Just . view blogConfig <$> liftIO (readTVarIO blog)
withBlog :: BlogConfig m -> (Blog m -> IO ()) -> IO ()
withBlog cfg action = do
mb <- runExceptT $ initBlog cfg
case mb of
Left err -> do
hPutStrLn stderr err
exitFailure
Right b -> do
tb <- atomically $ newTVar b
_ <- forkIO $ manageEntryCache tb (b^.blogCacheChannel)
action $ Blog (Just tb)
blogEntries :: (Functor io, MonadIO io, Monad m)
=> Blog m
-> EntryQuery
-> Maybe (IxSet Entry -> IxSet Entry)
-> io (m Html)
blogEntries (Blog Nothing) _ _ = return $ return mempty
blogEntries (Blog (Just tb)) eq qfun = do
_ <- liftIO . forkIO $ manageEntryUpdates tb
b <- liftIO $ readTVarIO tb
let es = toList . fromMaybe id qfun $ b^.entries
renderEntries b $ sortBy (eqSortBy eq) es
manageEntryUpdates :: TVar (Internal.Blog m) -> IO ()
manageEntryUpdates tb = do
b <- liftIO $ readTVarIO tb
let luc = b^.lastUpdateCheck
now <- liftIO getCurrentTime
let interval = max 1 . fromInteger . updateInterval $ b^.blogConfig
shouldCheckForUpdate <- liftIO . atomically $ updateUpdateTime now luc interval
when shouldCheckForUpdate $ do
blog <- liftIO $ readTVarIO tb
u <- runExceptT $ updateBlog blog
case u of
Left err -> hPutStrLn stderr err
Right blog' -> liftIO . atomically $ writeTVar tb blog'
where
updateUpdateTime :: UTCTime -> UTCTime -> NominalDiffTime-> STM Bool
updateUpdateTime now luc interval
| diffUTCTime now luc > interval * 60 = do
modifyTVar tb $ lastUpdateCheck .~ now
return True
| otherwise = return False
manageEntryCache :: TVar (Internal.Blog m) -> TChan (Integer, CachedEntry) -> IO ()
manageEntryCache tb tc = forever $ do
(i,h) <- atomically $ readTChan tc
atomically . modifyTVar tb $ blogEntryCache %~ Map.insert i h