Prepare for some persistence

.gitignore

@@ -1,2 +1,3 @@
 dist-newstyle
 .envrc
+/FeedMonad/state/

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 }

FeedMonad/FeedMonad.cabal

@@ -23,12 +23,15 @@ extra-source-files: CHANGELOG.md
 
 library
     exposed-modules:  MyLib
-                      Trace
+                      Data.Category
-                      FeedMonad
                       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:

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
+    acid-state base bytestring containers http-client http-client-tls
-    http-client-tls lens mtl safecopy servant servant-server text
+    lens mtl safecopy servant servant-server text xdg-basedir
-    xdg-basedir
   ];
-  executableHaskellDepends = [ base ];
   license = "unknown";
   hydraPlatforms = lib.platforms.none;
 }

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

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

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
+  }

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]

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