65 lines
1.7 KiB
Haskell
65 lines
1.7 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(..)
|
|
-- * Query functions
|
|
, GetEntries(..)
|
|
, GetEntry(..)
|
|
)
|
|
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)
|
|
|
|
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)
|
|
|
|
getEntries :: FeedId -> Query FeedMonadState [Entry]
|
|
getEntries fid = asks (toListOf (feeds . ix fid . traversed))
|
|
|
|
getEntry :: FeedId -> EntryId -> Query FeedMonadState (Maybe Entry)
|
|
getEntry fid eid = asks (preview (feeds . ix fid . ix eid))
|
|
|
|
deriveSafeCopy 0 'base ''FeedMonadState
|
|
|
|
makeAcidic ''FeedMonadState ['saveEntry, 'getEntries, 'getEntry]
|