Updates Lists API

cofree-bot.cabal

@@ -102,3 +102,4 @@ library
     , process
     , random
     , vector
+    , xdg-basedir

src/CofreeBot/Bot.hs

@@ -43,9 +43,6 @@ module CofreeBot.Bot
 import           CofreeBot.Utils
 import           CofreeBot.Utils.ListT
 import qualified Control.Arrow                 as Arrow
-import           Control.Exception              ( catch
-                                                , throwIO
-                                                )
 import           Control.Lens                   ( (^.)
                                                 , _Just
                                                 , ifolded
@@ -64,13 +61,11 @@ import qualified Data.Map.Strict               as Map
 import           Data.Profunctor
 import           Data.Profunctor.Traversing
 import qualified Data.Text                     as T
-import qualified Data.Text.IO                  as T
 import           Data.These
 import           Network.Matrix.Client
 import           Network.Matrix.Client.Lens
 import           System.Directory               ( createDirectoryIfMissing )
 import           System.IO
-import           System.IO.Error                ( isDoesNotExistError )
 import           System.Random
 
 --------------------------------------------------------------------------------
@@ -293,10 +288,6 @@ type MatrixBot m s = Bot m s (RoomID, Event) (RoomID, Event)
 liftMatrixIO :: (MonadIO m, MonadError MatrixError m) => MatrixIO x -> m x
 liftMatrixIO m = liftEither =<< liftIO m
 
-readFileMaybe :: String -> IO (Maybe T.Text)
-readFileMaybe path = fmap Just (T.readFile path)
-  `catch` \e -> if isDoesNotExistError e then pure Nothing else throwIO e
-
 -- | A Matrix 'Server' for connecting a 'Bot' to the Matrix protocol.
 matrix
   :: forall m

src/CofreeBot/Bot/Behaviors/Lists.hs

@@ -3,6 +3,9 @@ module CofreeBot.Bot.Behaviors.Lists
   ( listsBot
   ) where
 
+-- TODO: I want a bot combinator ala Sessionize that allows you take
+-- any bot and save its state to disk on updates.
+
 --------------------------------------------------------------------------------
 
 import           CofreeBot.Bot
@@ -15,15 +18,15 @@ import qualified Data.IntMap.Strict            as IntMap
 import           Data.IntMap.Strict             ( IntMap )
 import qualified Data.Map.Strict               as Map
 import           Data.Map.Strict                ( Map )
+import           Data.Maybe                     ( fromMaybe )
 import           Data.Profunctor
 import qualified Data.Text                     as T
-import Data.Maybe (fromMaybe)
 
 --------------------------------------------------------------------------------
 
 data ListItemAction = Insert T.Text | Modify Int T.Text | Remove Int
 
-data ListAction = CreateList T.Text | ModifyList T.Text ListItemAction | RemoveList T.Text | List T.Text
+data ListAction = CreateList T.Text | ModifyList T.Text ListItemAction | DeleteList T.Text | List T.Text
 
 listItemBot :: Monad m => Bot m (IntMap T.Text) ListItemAction T.Text
 listItemBot = Bot $ \s -> \case
@@ -44,25 +47,36 @@ listsBot' = Bot $ \s -> \case
     let t = fromMaybe IntMap.empty $ Map.lookup name s
     t' <- fmap snd $ runBot listItemBot t action
     pure ("List Updated", Map.insert name t' s)
-  RemoveList name -> pure ("List deleted", Map.delete name s)
+  DeleteList name -> pure ("List deleted", Map.delete name s)
   List       name -> pure (T.pack $ show $ Map.lookup name s, s)
 
 listsBot :: Monad m => Bot m (Map T.Text (IntMap T.Text)) T.Text T.Text
 listsBot = dimap (parseOnly parseListAction) indistinct $ emptyBot \/ listsBot'
 
 parseListAction :: Parser ListAction
 parseListAction =
-  parseCreateList <|> parseModifyList <|> parseRemoveList <|> parseListList
+  parseCreateList
+    <|> parseDeleteList
+    <|> parseShowList
+    <|> parseAddListItem
+    <|> parseRemoveListItem
+    <|> parseUpdateListItem
  where
   parseCreateList = "create" *> skipSpace *> fmap CreateList (takeTill isSpace)
-  parseModifyList =
+  parseDeleteList = "delete" *> skipSpace *> fmap DeleteList (takeTill isSpace)
+  parseShowList   = "show" *> skipSpace *> fmap List (takeTill isSpace)
+  parseAddListItem =
     "add"
       *>  skipSpace
       *>  fmap ModifyList (takeTill isSpace)
       <*> fmap Insert     takeText
-  parseRemoveList =
+  parseRemoveListItem =
     "remove"
       *>  skipSpace
       *>  fmap ModifyList (takeTill isSpace)
       <*> fmap Remove     decimal
-  parseListList = "show" *> skipSpace *> fmap List takeText
+  parseUpdateListItem =
+    "update"
+      *>  skipSpace
+      *>  fmap ModifyList (takeTill isSpace)
+      <*> (fmap Modify decimal <* skipSpace <*> takeText)

src/CofreeBot/Bot/Context.hs

@@ -17,21 +17,30 @@ module CofreeBot.Bot.Context
   , SessionOutput(..)
   , sessionize
   , simplifySessionBot
+
+    -- * Persistence
+  , persistentBot
   ) where
 
 --------------------------------------------------------------------------------
 
 import           CofreeBot.Bot
+import           CofreeBot.Utils                ( readFileMaybe )
 import           CofreeBot.Utils.ListT          ( emptyListT )
 import           Control.Applicative
 import qualified Control.Arrow                 as Arrow
+import           Control.Monad.IO.Class
 import           Data.Attoparsec.Text
 import           Data.Bifunctor                 ( Bifunctor(first) )
+import           Data.Foldable
 import qualified Data.IntMap.Strict            as IntMap
 import           Data.IntMap.Strict             ( IntMap )
+import           Data.Map                       ( Map )
 import           Data.Profunctor                ( second' )
 import qualified Data.Text                     as T
 import           Network.Matrix.Client
+import           System.Directory               ( createDirectoryIfMissing )
+import           System.Environment.XDG.BaseDir ( getUserCacheDir )
 
 --------------------------------------------------------------------------------
 
@@ -149,3 +158,31 @@ simplifySessionBot tshow p (Bot bot) = Bot $ \s i -> do
     SessionStarted n -> "Session Started: '" <> T.pack (show n) <> "'."
     SessionEnded   n -> "Session Ended: '" <> T.pack (show n) <> "'."
     InvalidSession n -> "Invalid Session: '" <> T.pack (show n) <> "'."
+
+--------------------------------------------------------------------------------
+
+-- | Transform a standard 'Bot' with in-memory state to one which
+-- persists its state to disk.
+persistentBot
+  :: (MonadIO m, Show s, Read s, Monoid s)
+  => (i -> T.Text)
+  -> Bot m (Map T.Text s) i o
+  -> Bot m () i o
+persistentBot parseKey (Bot bot) = Bot $ \() i -> do
+  let key = parseKey i
+  s       <- liftIO $ readState key
+  (o, s') <- bot (fold s) i
+  liftIO $ saveState key s'
+  pure $ (o, ())
+
+readState :: Read s => T.Text -> IO (Maybe s)
+readState key = do
+  cache <- getUserCacheDir "cofree-bot"
+  s     <- readFileMaybe $ cache <> "/" <> T.unpack key
+  pure $ fmap (read . T.unpack) s
+
+saveState :: Show s => T.Text -> s -> IO ()
+saveState key state = do
+  cache <- getUserCacheDir "cofree-bot"
+  createDirectoryIfMissing True cache
+  writeFile (cache <> "/" <> T.unpack key) (show state)

src/CofreeBot/Utils.hs

@@ -20,14 +20,19 @@ module CofreeBot.Utils
     -- * Misc
     distinguish
   , PointedChoice(..)
+  , readFileMaybe
   ) where
 
 -------------------------------------------------------------------------------
 
 import           Control.Applicative
 import           Control.Arrow                  ( (&&&) )
+import           Control.Exception
 import           Data.Kind
+import qualified Data.Text                     as T
+import qualified Data.Text.IO                  as T
 import           Data.These                     ( These )
+import           System.IO.Error                ( isDoesNotExistError )
 
 -------------------------------------------------------------------------------
 
@@ -93,3 +98,10 @@ distinguish f x | f x       = Right x
 class PointedChoice p where
   pleft :: p a b -> p (x \*/ a) (x \*/ b)
   pright :: p a b -> p (a \*/ x) (b \*/ x)
+
+
+--------------------------------------------------------------------------------
+
+readFileMaybe :: String -> IO (Maybe T.Text)
+readFileMaybe path = fmap Just (T.readFile path)
+  `catch` \e -> if isDoesNotExistError e then pure Nothing else throwIO e