{- This file is part of json-state. - - Written in 2015 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - - The author(s) have dedicated all copyright and related and neighboring - rights to this software to the public domain worldwide. This software is - distributed without any warranty. - - You should have received a copy of the CC0 Public Domain Dedication along - with this software. If not, see - . -} -- | This module provides a function for loading a state value from a JSON -- file, and a function which generates a safe scalable saver function. The -- JSON files are written using the @aeson-pretty@ package, so that they are -- easy to read and modify manually if needed. -- -- The save function generator, @mkSaveState@, returns a function which -- saves settings when called, but only at most once in @t@, the time interval -- passed to the generator. For example, if you pass an interval of 3 seconds, -- you can safely call the generated save function even 100 times a second, and -- the JSON file will still get updated just once in 3 seconds, avoiding an -- overload of file I/O. -- -- The actual saving happens in a dedicated worker thread, so even when a save -- does occur, it won't block the caller thread. The generator can be called -- once at program start, and the returned save function saved in application -- state. -- -- 'mkSaveStateVC' works similarly, but additionally provides a saver function -- which commits the change into a git repo. -- -- Note that while this simple periodic save-to-file method can serve a simple -- standalone application well, it won't work if you wish your data to be -- shared by multiple applications and allow them to read and write it at the -- same time. If that's the case, check out the @acid-state@ package, and other -- persistence related packages. module Data.JsonState ( loadState , mkSaveState , mkSaveStateVC , mkSaveStateChoose , stateFilePath ) where import Control.Debounce (mkDebounce) import Control.Exception import Control.Monad (liftM, void, when) import Data.Aeson (FromJSON, ToJSON, eitherDecode) import Data.Aeson.Encode.Pretty (encodePretty) import Data.Time.Units (TimeUnit) import Lib.Git import System.IO.Error (tryIOError) import qualified Data.ByteString.Lazy as B tryAny :: IO a -> IO (Either SomeException a) tryAny = try -- | Try to load state from a file. -- -- If an error occurs, 'Left' a pair is returned. The boolean indicates whether -- reading the file failed ('False') or parsing the content failed ('True'). -- The string is an error description. -- -- If the operation succeeds, 'Right' the loaded state data is returned. loadState :: FromJSON s => FilePath -- ^ File to load -> IO (Either (Bool, String) s) loadState file = do errOrStr <- tryIOError (B.readFile file) let pairOrStr = either (Left . (,) False . show) Right errOrStr return $ pairOrStr >>= either (Left . (,) True) Right . eitherDecode saveAction :: ToJSON s => FilePath -> s -> IO () saveAction file s = do res <- tryAny $ B.writeFile file $ encodePretty s case res of Left err -> void $ tryAny $ do putStrLn "json-state saveAction caught exception:" print err Right () -> return () -- | Prepare a save action which writes state into a JSON file. This action -- defers the work to a separate dedicated thread, and ensures the file isn't -- saved more than once within the given time interval. -- -- The action is non-blocking but there is a chance a save is missed if saves -- are triggered simultaneously from different threads. -- -- You can call the returned action from your UI thread as a reaction to a -- state change, without worrying about delay or IO load. mkSaveState :: (TimeUnit t, ToJSON s) => t -- ^ Minimal time interval between saves -> FilePath -- ^ File to save -> IO (s -> IO ()) mkSaveState interval file = liftM fst $ mkDebounce interval (saveAction file) saveActionVC :: ToJSON s => FilePath -> Config -> String -> (s, Bool) -> IO () saveActionVC file cfg msg (s, git) = do res <- tryAny $ do saveAction (configCwd cfg ++ '/' : file) s when git $ runGit cfg $ do add [file] commit [] "json-state" "json@state" msg [] case res of Left err -> void $ tryAny $ do putStrLn "json-state saveActionVC caught exception:" print err Right () -> return () -- | Like 'mkSaveState', but also takes a repository path. Creates a Git -- repository there if there isn't yet. Two save actions are returned. The -- first one simply saves state to a file, just like in 'mkSaveState'. The -- second one saves to file and then commits it into the Git repository. -- -- Note that the file path is relative to the repo path. For example, if you -- have the repo in \"/home/joe/repo\" and the file is \"/home/joe/repo/file\", -- pass just \"file\" as the file path. mkSaveStateVC :: (TimeUnit t, ToJSON s) => t -- ^ Minimal time interval between saves -> FilePath -- ^ File to save, path relative to repo path -> FilePath -- ^ Path of the Git repository -> String -- ^ Commit message to use in automatic commits -> IO ( s -> IO () , s -> IO () ) mkSaveStateVC interval file repo msg = do let cfg = makeConfig repo Nothing runGit cfg $ initDB False action <- liftM fst $ mkDebounce interval (saveActionVC file cfg msg) let withgit s = action (s, True) nogit s = action (s, False) return (nogit, withgit) -- | This is a variant which returns a single save action, which either uses or -- doesn't use a Git repo. If the repo path (3rd argument) is 'Nothing', then -- Git isn't used at all and the file path is treated like 'mkSaveState' would. -- Otherwise, i.e. if a repo path is specified, the returned action will commit -- changes to the Git repo, and the repo and file path arguments are treated -- like 'mkSaveStateVC' would, i.e. the file path is relative to the repo. -- -- If you use this function, also use 'stateFilePath' to determine the correct -- path to pass to 'loadState'. mkSaveStateChoose :: (TimeUnit t, ToJSON s) => t -- ^ Minimal time interval between saves -> FilePath -- ^ File to save. If the repo path (next argument) is -- 'Nothing', no Git repo is used, and this path is relative -- to the process working dir, or absolute. If a repo path is -- specified, this path is relative to repo path, and the -- returned action also commits the file to the Git repo. -> Maybe FilePath -- ^ Optional path of the Git repository. If you pass -- 'Nothing', a Git repo won't be used. If you pass 'Just' a -- repo path, the save action will commit the change. -> String -- ^ Commit message to use in automatic commits -> IO (s -> IO ()) mkSaveStateChoose interval file (Just repo) msg = liftM snd $ mkSaveStateVC interval file repo msg mkSaveStateChoose interval file Nothing _msg = mkSaveState interval file -- | If you use 'mkSaveStateChoose' to save the state, that function combines -- the repo path and the file path when needed, to determine the full path of -- the state file. But then, how do you determine which path to pass to -- 'loadState'? This is exactly what this function does. Pass it the optional -- repo path and the file path you passed to 'mkSaveStateChoose', and you'll -- get a full path you can pass to 'loadState'. stateFilePath :: FilePath -> Maybe FilePath -> FilePath stateFilePath file (Just dir@(_:_)) = if last dir == '/' then dir ++ file else dir ++ '/' : file stateFilePath file _ = file