add cache:clear procedure

CHANGELOG.md

@@ -7,9 +7,18 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ## [Unreleased]
 
+### Added
+
+- Config file `config.toml` + `store-path` option [#40]
+- `cache:clear` procedure
+
+### Changed
+
+- Use GHC `v8.10.2`
+
 ### Fixed
 
-- Task not found when using long ids containing dash
+- Task not found when using long ids containing dash [#43]
 - Short ids for worktime --more query [#39]
 
 ## [1.0.1] - 2020-08-16
@@ -52,10 +61,6 @@ reports).
 
 ## [0.4.4] - 2020-07-27
 
-### Fixed
-
-- Bad build state for update cmd [#27]
-
 ### Added
 
 - AUR package support [#26]
@@ -66,6 +71,10 @@ reports).
 - Replace `Data.Duration` by own duration with tests [#24]
 - Upgrade ghc `v8.8.3`
 
+### Fixed
+
+- Bad build state for update cmd [#27]
+
 ## [0.4.3] - 2020-03-11
 
 ### Added
@@ -271,3 +280,5 @@ First release :tada:
 [#34]: https://github.com/soywod/unfog/issues/34
 [#37]: https://github.com/soywod/unfog/issues/37
 [#39]: https://github.com/soywod/unfog/issues/39
+[#40]: https://github.com/soywod/unfog/issues/40
+[#43]: https://github.com/soywod/unfog/issues/43

src/ArgParser.hs

@@ -33,8 +33,12 @@ data Command
 data Procedure
   = ShowVersion JsonOpt
   | Upgrade
+  | ClearCache
 
-data Arg = CommandArg Command | QueryArg Query | ProcedureArg Procedure
+data Arg
+  = CommandArg Command
+  | QueryArg Query
+  | ProcedureArg Procedure
 
 parseArgs :: IO Arg
 parseArgs = parseArgs' =<< Env.getArgs
@@ -195,7 +199,8 @@ procedures =
   foldr1
     (<>)
     [ upgradeProcedure,
-      versionProcedure
+      versionProcedure,
+      clearCacheProcedure
     ]
 
 upgradeProcedure :: Mod CommandFields Arg
@@ -210,6 +215,12 @@ versionProcedure = command "version" $ info parser infoMod
     infoMod = progDesc "Show the version"
     parser = ProcedureArg . ShowVersion <$> jsonOptParser
 
+clearCacheProcedure :: Mod CommandFields Arg
+clearCacheProcedure = command "cache:clear" $ info parser infoMod
+  where
+    infoMod = progDesc "Clear the state cache"
+    parser = pure $ ProcedureArg ClearCache
+
 -- Readers
 
 readUTCTime :: TimeZone -> String -> Maybe UTCTime

src/Command.hs

@@ -4,12 +4,12 @@ import qualified ArgParser as Arg
 import Control.Applicative ((<|>))
 import Data.Maybe (isJust, isNothing)
 import Data.Time (TimeZone, UTCTime, getCurrentTime, getCurrentTimeZone)
-import qualified Data.UUID.V4 as UUID (nextRandom)
+import qualified Data.UUID.V4 as UUID
 import Event.Type (Event (..))
 import Response
 import State (State (..))
-import qualified State (applyAll, getTasks, new, readFile, rebuild, writeFile)
-import qualified Store (appendFile, readFile)
+import qualified State
+import qualified Store
 import Task
 import Text.Printf (printf)
 
@@ -30,14 +30,14 @@ handle :: Arg.Command -> IO ()
 handle arg = do
   now <- getCurrentTime
   tzone <- getCurrentTimeZone
-  state <- State.readFile <|> (State.rebuild <$> Store.readFile) <|> return State.new
+  state <- State.readCache <|> (State.rebuild <$> Store.readFile) <|> return State.new
   rndId <- show <$> UUID.nextRandom
   let cmds = parseCommands now tzone state rndId arg
   let evts = concatMap (execute state) cmds
   let state' = State.applyAll state evts
   let shortenId' = shortenId $ getShortIdLength $ State.getTasks state
   Store.appendFile evts
-  State.writeFile state'
+  State.writeCache state'
   notify shortenId' cmds subscribers
 
 parseCommands :: UTCTime -> TimeZone -> State -> Id -> Arg.Command -> [Command]
@@ -88,7 +88,7 @@ editTask now _ rtype (State _ tasks) id desc proj due = case findById id tasks o
 -- due' = if isNothing due then getDue task else due
 
 startTask :: UTCTime -> ResponseType -> State -> Id -> Command
-startTask now rtype state id = case findById id (State.getTasks state) of
+startTask now rtype (State _ tasks) id = case findById id tasks of
   Nothing -> Error rtype "task not found"
   Just task -> validate task
   where
@@ -99,7 +99,7 @@ startTask now rtype state id = case findById id (State.getTasks state) of
       | otherwise = StartTask now rtype (getId task)
 
 stopTask :: UTCTime -> ResponseType -> State -> Id -> Command
-stopTask now rtype state id = case findById id (State.getTasks state) of
+stopTask now rtype (State _ tasks) id = case findById id tasks of
   Nothing -> Error rtype "task not found"
   Just task -> validate task
   where
@@ -110,7 +110,7 @@ stopTask now rtype state id = case findById id (State.getTasks state) of
       | otherwise = StopTask now rtype (getId task)
 
 toggleTask :: UTCTime -> ResponseType -> State -> Id -> Command
-toggleTask now rtype state id = case findById id (State.getTasks state) of
+toggleTask now rtype (State _ tasks) id = case findById id tasks of
   Nothing -> Error rtype "task not found"
   Just task -> validate task
   where
@@ -121,7 +121,7 @@ toggleTask now rtype state id = case findById id (State.getTasks state) of
       | otherwise = StartTask now rtype $ getId task
 
 doTask :: UTCTime -> ResponseType -> State -> Id -> Command
-doTask now rtype state id = case findById id (State.getTasks state) of
+doTask now rtype (State _ tasks) id = case findById id tasks of
   Nothing -> Error rtype "task not found"
   Just task -> validate task
   where
@@ -131,7 +131,7 @@ doTask now rtype state id = case findById id (State.getTasks state) of
       | otherwise = DoTask now rtype (getId task)
 
 undoTask :: UTCTime -> ResponseType -> State -> Id -> Command
-undoTask now rtype state id = case findById id (State.getTasks state) of
+undoTask now rtype (State _ tasks) id = case findById id tasks of
   Nothing -> Error rtype "task not found"
   Just task -> validate task
   where
@@ -141,7 +141,7 @@ undoTask now rtype state id = case findById id (State.getTasks state) of
       | otherwise = UndoTask now rtype (getId task)
 
 deleteTask :: UTCTime -> ResponseType -> State -> Id -> Command
-deleteTask now rtype state id = case findById id (State.getTasks state) of
+deleteTask now rtype (State _ tasks) id = case findById id tasks of
   Nothing -> Error rtype "task not found"
   Just task -> validate task
   where
@@ -150,7 +150,7 @@ deleteTask now rtype state id = case findById id (State.getTasks state) of
       | otherwise = DeleteTask now rtype (getId task)
 
 undeleteTask :: UTCTime -> ResponseType -> State -> Id -> Command
-undeleteTask now rtype state id = case findById id (State.getTasks state) of
+undeleteTask now rtype (State _ tasks) id = case findById id tasks of
   Nothing -> Error rtype "task not found"
   Just task -> validate task
   where

src/File.hs

@@ -17,8 +17,8 @@ getDefaultDir = do
   createDirectoryIfMissing True fpath
   return fpath
 
-getPath :: String -> IO String
-getPath fname = (++ "/" ++ fname) <$> getDefaultDir
+getFullPath :: String -> IO String
+getFullPath fname = (++ "/" ++ fname) <$> getDefaultDir
 
 readFromPath :: String -> IO String
 readFromPath fpath = do
@@ -29,4 +29,4 @@ readFromPath fpath = do
   return fcontent
 
 readFromName :: String -> IO String
-readFromName = readFromPath <=< getPath
+readFromName = readFromPath <=< getFullPath

src/Procedure.hs

@@ -4,13 +4,16 @@ import ArgOptions
 import qualified ArgParser as Arg
 import Control.Monad (void)
 import Response
+import qualified State
 import System.Process (system)
 
 data Procedure
   = ShowVersion JsonOpt
   | DoUpgrade
+  | ClearCache
   deriving (Show, Read)
 
 handle :: Arg.Procedure -> IO ()
 handle (Arg.ShowVersion jsonOpt) = send (parseResponseType jsonOpt) (VersionResponse "1.0.1")
 handle Arg.Upgrade = void $ system "curl -sSL https://raw.githubusercontent.com/soywod/unfog/master/bin/install.sh | bash"
+handle Arg.ClearCache = State.clearCache >> putStrLn "Cache cleared!"

src/Query.hs

@@ -23,7 +23,7 @@ data Query
 handle :: Arg.Query -> IO ()
 handle arg = do
   now <- getCurrentTime
-  state <- State.readFile <|> (State.rebuild <$> Store.readFile) <|> return State.new
+  state <- State.readCache <|> (State.rebuild <$> Store.readFile) <|> return State.new
   let query = parseQuery now state arg
   execute query
 

src/State.hs

@@ -1,8 +1,10 @@
 module State where
 
+import Control.Applicative ((<|>))
 import Data.Maybe
 import Event.Type (Event (..))
 import qualified File
+import System.Directory (removeFile)
 import Task hiding (new)
 
 -- Model
@@ -20,29 +22,29 @@ new =
       _tasks = []
     }
 
--- Getters
-
-getContext :: State -> Project
-getContext = _ctx
+getCtx :: State -> Project
+getCtx = _ctx
 
 getTasks :: State -> [Task]
 getTasks = _tasks
 
--- Read & Write
+-- IO
+
+fileName = ".state.cache"
+
+readCache :: IO State
+readCache = read <$> File.readFromName fileName
 
-readFile :: IO State
-readFile = read <$> File.readFromName "state"
+writeCache :: State -> IO ()
+writeCache state = flip writeFile (show state) =<< File.getFullPath fileName
 
-writeFile :: State -> IO ()
-writeFile state = writeFile' state' =<< File.getPath "state"
-  where
-    state' = show state
-    writeFile' = flip Prelude.writeFile
+clearCache :: IO ()
+clearCache = (removeFile =<< File.getFullPath fileName) <|> mempty
 
 -- Event sourcing
 
 rebuild :: [Event] -> State
-rebuild = applyAll $ State Nothing []
+rebuild = applyAll new
 
 applyAll :: State -> [Event] -> State
 applyAll = foldl apply

src/Store.hs

@@ -7,10 +7,12 @@ import qualified Event.MigrationV0 as V0
 import Event.Type (Event, readEvents)
 import qualified File
 
+fileName = "store"
+
 getFilePath :: IO String
 getFilePath = do
   pathFromTOML <- Config.getStorePath
-  defaultPath <- File.getPath "store"
+  defaultPath <- File.getFullPath fileName
   return $ fromMaybe defaultPath pathFromTOML
 
 readFile :: IO [Event]

src/Task.hs

@@ -89,6 +89,9 @@ getDeleted = _deleted
 
 type Predicate = Task -> Bool
 
+both :: Predicate -> Predicate -> Predicate
+both f g x = f x && g x
+
 notDone :: Predicate
 notDone = isNothing . getDone
 
@@ -105,9 +108,6 @@ isDuePassed now task = case getDue task of
   Nothing -> False
   Just due -> due < now
 
-both :: Predicate -> Predicate -> Predicate
-both f g x = f x && g x
-
 filterWith :: [Predicate] -> [Task] -> [Task]
 filterWith predicates = filter matchAll
   where