107 lines
3.1 KiB
Haskell
107 lines
3.1 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
module Database
|
|
(
|
|
-- * Internal State
|
|
FeedMonadState
|
|
, emptyFeedMonadState
|
|
, FeedId(..)
|
|
, EntryId(..)
|
|
-- * Update functions
|
|
, SaveEntry(..)
|
|
, SaveEntries(..)
|
|
-- * Query functions
|
|
, GetEntries(..)
|
|
, GetEntry(..)
|
|
, CountEntries(..)
|
|
, UnseenEntries(..)
|
|
)
|
|
where
|
|
|
|
import Data.Entry
|
|
import Data.Map.Strict (Map)
|
|
import Data.SafeCopy
|
|
import GHC.Generics (Generic)
|
|
import Data.Acid
|
|
import Control.Lens
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad.Reader (asks)
|
|
import Data.URL (URL)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as S
|
|
|
|
newtype FeedId = FeedId URL
|
|
deriving (Show, Eq, Ord, Generic)
|
|
|
|
instance SafeCopy FeedId
|
|
|
|
newtype EntryId = EntryId URL
|
|
deriving (Show, Eq, Ord, Generic)
|
|
|
|
instance SafeCopy EntryId
|
|
|
|
newtype FeedMonadState = FeedMonadState
|
|
{ _feeds :: Map FeedId (Map EntryId Entry) }
|
|
deriving Show
|
|
|
|
emptyFeedMonadState :: FeedMonadState
|
|
emptyFeedMonadState = FeedMonadState mempty
|
|
|
|
feeds :: Lens' FeedMonadState (Map FeedId (Map EntryId Entry))
|
|
feeds = lens _feeds (\ fms f -> fms{_feeds=f})
|
|
|
|
|
|
-- | Save the entry to the database
|
|
saveEntry :: FeedId -> EntryId -> Entry -> Update FeedMonadState ()
|
|
saveEntry fid eid en = modifying (feeds . at fid . non mempty . at eid) (<|> Just en)
|
|
|
|
-- | Save a batch of entries to the database
|
|
--
|
|
-- Saves the new entries, preferring the old entries over the new entries
|
|
saveEntries :: FeedId -> [Entry] -> Update FeedMonadState ()
|
|
saveEntries fid entries = modifying (feeds . at fid) (\old -> Just (toEntryMap entries) <> old)
|
|
where
|
|
toEntryMap = foldMap (\e -> M.singleton (EntryId (entryURL e)) e)
|
|
|
|
getEntries :: FeedId -> Query FeedMonadState [Entry]
|
|
getEntries fid = asks (toListOf (feeds . ix fid . traversed))
|
|
|
|
-- | Count the number of entries in a feed
|
|
countEntries :: FeedId -> Query FeedMonadState Int
|
|
countEntries fid = asks (lengthOf (feeds . ix fid . traversed))
|
|
|
|
getEntry :: FeedId -> EntryId -> Query FeedMonadState (Maybe Entry)
|
|
getEntry fid eid = asks (preview (feeds . ix fid . ix eid))
|
|
|
|
-- | Filter the unseen entries
|
|
--
|
|
unseenEntries :: FeedId -> Set EntryId -> Query FeedMonadState (Set EntryId)
|
|
-- This seems to be an unfortunate effect of acid-state :/. If I try
|
|
-- to insert all the entries and let the 'Map' handle updates, the
|
|
-- acid-state event gets humongous. With my tests with only a few
|
|
-- feeds, each run uses about a megabyte of disk space. Multiply this
|
|
-- by 48 times a day, 365 times a year, you would get 17G a year.
|
|
--
|
|
-- Even though the save isn't now done in a single atomic operation,
|
|
-- this should be fine, because at worst we would be inserting
|
|
-- duplicates and the 'saveEntries' function already handles that.
|
|
unseenEntries fid s = do
|
|
keys <- asks (foldMapOf (feeds . ix fid) M.keysSet)
|
|
pure $ s `S.difference` keys
|
|
|
|
deriveSafeCopy 0 'base ''FeedMonadState
|
|
|
|
makeAcidic ''FeedMonadState
|
|
[ 'saveEntry
|
|
, 'getEntries
|
|
, 'getEntry
|
|
, 'saveEntries
|
|
, 'countEntries
|
|
, 'unseenEntries
|
|
]
|