From 6440550f487b8a7a424e224ea1bf6d85052eb5eb Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Tue, 2 Feb 2016 12:31:36 +0000
Subject: [PATCH] Support loading and saving to JSON, step 5

---
 src/Vervis.hs | 40 +++++++++++++++++++++++++++++++++++++++-
 vervis.cabal  |  1 +
 2 files changed, 40 insertions(+), 1 deletion(-)

diff --git a/src/Vervis.hs b/src/Vervis.hs
index 860c52d..23cb893 100644
--- a/src/Vervis.hs
+++ b/src/Vervis.hs
@@ -36,6 +36,7 @@ module Vervis
     , Project (..)
     , Vervis ()
     , runVervis
+    , saveState
     , Server (..)--TODO remove this type later...
     , subdirs
     , lastChange
@@ -46,7 +47,7 @@ where
 
 import Control.Monad (join)
 import Control.Monad.Fix (MonadFix)
-import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.IO.Class
 import Control.Monad.Trans.RWS (RWST (..))
 import Data.Aeson
 import Data.CaseInsensitive (CI)
@@ -61,15 +62,43 @@ import Data.Hourglass
 import Data.JsonState
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Text (Text)
+import Data.Time.Units
 import GHC.Generics
 import System.Directory.Tree hiding (name, file, err)
 import System.FilePath ((</>))
 import System.Hourglass (dateCurrent)
 
+import qualified Control.Monad.Trans.RWS as RWS
 import qualified Data.CaseInsensitive as CI
 import qualified Data.HashMap.Lazy as M
 import qualified Data.Text as T
 
+-- | Fetch the value of the environment.
+ask :: Vervis (VervisEnv)
+ask = Vervis RWS.ask
+
+-- | Retrieve a function of the current environment.
+asks :: (VervisEnv -> a) -> Vervis a
+asks = Vervis . RWS.asks
+
+-- | Fetch the current value of the state within the monad.
+get :: Vervis (VervisState)
+get = Vervis RWS.get
+
+-- | Get a specific component of the state, using a projection function
+-- supplied.
+gets :: (VervisState -> a) -> Vervis a
+gets = Vervis . RWS.gets
+
+-- | @'put' s@ sets the state within the monad to @s@.
+put :: VervisState -> Vervis ()
+put = Vervis . RWS.put
+
+-- | @'modify' f@ is an action that updates the state to the result of
+-- applying @f@ to the current state.
+modify :: (VervisState -> VervisState) -> Vervis ()
+modify = Vervis . RWS.modify
+
 instance (CI.FoldCase a, FromJSON a) => FromJSON (CI a) where
     parseJSON v = CI.mk <$> parseJSON v
 
@@ -197,6 +226,7 @@ instance FromJSON Project
 data VervisEnv = VervisEnv
     { veName :: Text
     , veDir  :: FilePath
+    , veSave :: VervisState -> Vervis ()
     }
 
 data VervisState = VervisState
@@ -232,13 +262,21 @@ runVervis name file dir comp = do
         Left (False, err) -> error $ "Loading JSON state failed: " ++ err
         Left (True, err)  -> error $ "Parsing JSON state failed: " ++ err
         Right vstate -> do
+            save <- mkSaveState (3 :: Second) file
             let venv = VervisEnv
                     { veName = name
                     , veDir  = dir
+                    , veSave = liftIO . save
                     }
             (a, _s) <- runVervis' venv vstate comp
             return a
 
+saveState :: Vervis ()
+saveState = do
+    save <- asks veSave
+    vstate <- get
+    save vstate
+
 data Server = Server
     { serverName   :: Text
     , serverDir    :: FilePath
diff --git a/vervis.cabal b/vervis.cabal
index 28b547f..85718c7 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -39,6 +39,7 @@ library
                      , hashable
                      , hourglass
                      , text                 >=1
+                     , time-units
                      , transformers         >=0.4.2
                      , unordered-containers >=0.2.5
   hs-source-dirs:      src