diff --git a/.gitignore b/.gitignore index cd7dd01..3fb7520 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ dist-newstyle .envrc +/FeedMonad/state/ diff --git a/FeedMonad-demo/app/Main.hs b/FeedMonad-demo/app/Main.hs index ce1944a..96d8579 100644 --- a/FeedMonad-demo/app/Main.hs +++ b/FeedMonad-demo/app/Main.hs @@ -3,7 +3,14 @@ module Main where import FeedMonad import Data.Category +import Data.Entry (URL(URL)) + +myFeeds :: [ Category URL ] +myFeeds = + [ Category "News" + [ Leaf (URL "https://github.com/feediron/feediron-recipes/commits/master.atom")] + ] main :: IO () main = do - defaultMain defaultConfig{feeds = [ Category "News" [] ]} + defaultMain defaultConfig{feeds = myFeeds } diff --git a/FeedMonad/FeedMonad.cabal b/FeedMonad/FeedMonad.cabal index 500ccc1..b57c925 100644 --- a/FeedMonad/FeedMonad.cabal +++ b/FeedMonad/FeedMonad.cabal @@ -23,12 +23,15 @@ extra-source-files: CHANGELOG.md library exposed-modules: MyLib - Trace - FeedMonad + Data.Category Data.Entry + Database + FeedMonad Middleware Paths_FeedMonad - Data.Category + Trace + Data.Environment + Control.Monad.App -- Modules included in this library but not exported. -- other-modules: diff --git a/FeedMonad/default.nix b/FeedMonad/default.nix index 434fa64..c1a104a 100644 --- a/FeedMonad/default.nix +++ b/FeedMonad/default.nix @@ -1,4 +1,4 @@ -{ mkDerivation, acid-state, base, bytestring, containers, dyre +{ mkDerivation, acid-state, base, bytestring, containers , http-client, http-client-tls, lens, lib, mtl, safecopy, servant , servant-server, text, xdg-basedir }: @@ -6,14 +6,10 @@ mkDerivation { pname = "FeedMonad"; version = "0.1.0.0"; src = ./.; - isLibrary = true; - isExecutable = true; libraryHaskellDepends = [ - acid-state base bytestring containers dyre http-client - http-client-tls lens mtl safecopy servant servant-server text - xdg-basedir + acid-state base bytestring containers http-client http-client-tls + lens mtl safecopy servant servant-server text xdg-basedir ]; - executableHaskellDepends = [ base ]; license = "unknown"; hydraPlatforms = lib.platforms.none; } diff --git a/FeedMonad/src/Control/Monad/App.hs b/FeedMonad/src/Control/Monad/App.hs new file mode 100644 index 0000000..2308e2d --- /dev/null +++ b/FeedMonad/src/Control/Monad/App.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DerivingVia #-} +module Control.Monad.App where + +import Data.Environment (Environment) +import Control.Monad.Reader ( MonadIO, MonadReader, ReaderT(..) ) + +newtype App a = App ( ReaderT Environment IO a ) + deriving + ( Functor + , Applicative + , Monad + , MonadReader Environment + , MonadIO + ) via ReaderT Environment IO + +runApp :: Environment -> App a -> IO a +runApp env (App f) = runReaderT f env diff --git a/FeedMonad/src/Data/Entry.hs b/FeedMonad/src/Data/Entry.hs index 886608f..dc304e9 100644 --- a/FeedMonad/src/Data/Entry.hs +++ b/FeedMonad/src/Data/Entry.hs @@ -1,13 +1,22 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} module Data.Entry where import Data.ByteString.Lazy (ByteString) import Data.Set (Set) import Data.Text (Text) import Control.Lens +import Data.SafeCopy +import GHC.Generics (Generic) newtype URL = URL String - deriving (Show) + deriving (Show, Eq, Ord, Generic) + +instance SafeCopy URL + newtype Tag = Tag Text - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance SafeCopy Tag data Entry = Entry { entryURL :: URL @@ -16,7 +25,7 @@ data Entry = Entry , entryScore :: Int , entryTags :: Set Tag } - deriving Show + deriving (Eq, Ord, Show) -- * Lenses for accessing relevant parts of entry @@ -38,3 +47,7 @@ score = lens entryScore (\ en n -> en{entryScore=n}) tags :: Lens' Entry (Set Tag) tags = lens entryTags (\ en txts -> en{entryTags=txts}) + + +-- * TH generated instances +deriveSafeCopy 0 'base ''Entry diff --git a/FeedMonad/src/Data/Environment.hs b/FeedMonad/src/Data/Environment.hs new file mode 100644 index 0000000..d1bd61d --- /dev/null +++ b/FeedMonad/src/Data/Environment.hs @@ -0,0 +1,9 @@ +module Data.Environment where +import Network.HTTP.Client (Manager) +import Database (FeedMonadState) +import Data.Acid (AcidState) + +data Environment = Environment + { environmentManager :: Manager + , environmentAcidState :: AcidState FeedMonadState + } diff --git a/FeedMonad/src/Database.hs b/FeedMonad/src/Database.hs new file mode 100644 index 0000000..1774bb4 --- /dev/null +++ b/FeedMonad/src/Database.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +module Database + ( + -- * Internal State + FeedMonadState + , emptyFeedMonadState + -- * 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) + +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] diff --git a/FeedMonad/src/FeedMonad.hs b/FeedMonad/src/FeedMonad.hs index cb4c817..bdd0d39 100644 --- a/FeedMonad/src/FeedMonad.hs +++ b/FeedMonad/src/FeedMonad.hs @@ -7,6 +7,13 @@ import Data.Entry (URL) import Middleware (Middleware) import Numeric.Natural (Natural) import Data.Category (Category) +import Data.Acid (openLocalState, AcidState (closeAcidState)) +import Control.Exception (bracket) +import Database (emptyFeedMonadState) +import Network.HTTP.Client.TLS (newTlsManager) +import Control.Monad.App (runApp) +import Data.Environment +import Control.Monad.Trans (liftIO) newtype Minutes = Minutes Natural @@ -34,4 +41,7 @@ defaultConfig = FeedMonad defaultMain :: FeedMonad -> IO () defaultMain f = - print $ feeds f + bracket (openLocalState emptyFeedMonadState) closeAcidState $ \st -> do + mgr <- newTlsManager + runApp (Environment mgr st) $ + liftIO $ print $ feeds f