diff --git a/Villefort.cabal b/Villefort.cabal --- a/Villefort.cabal +++ b/Villefort.cabal @@ -1,5 +1,5 @@ name: Villefort -version: 0.1.1.4 +version: 0.1.1.5 synopsis: Villefort is a task manager and time tracker written in haskell. description: Villefort is a browser based time tracker. homepage: https://github.com/Chrisr850/Villefort#readme @@ -12,8 +12,9 @@ build-type: Simple extra-source-files: README.md cabal-version: >=1.10 + data-files: data/date - , data/todo.db + , data/todo.db , data/day , templates/*.html , templates/*.ts @@ -34,7 +35,8 @@ , Villefort.Summary , Villefort.Config , Villefort.Server - build-depends: base >= 4.9 && < 5 + , Villefort.Definitions + build-depends: base >= 4.7 && < 5 , HDBC >= 2.4.0 && < 2.5 , HDBC-sqlite3 >= 2.3.3 && < 2.4 , split >= 0.2.3 && < 0.3 @@ -49,6 +51,7 @@ , directory , filepath , unix + , bytestring , transformers default-language: Haskell2010 @@ -74,7 +77,6 @@ main-is: Spec.hs build-depends: base , Villefort - , QuickCheck , HDBC >= 2.4.0 && < 2.5 , HDBC-sqlite3 >= 2.3.3 && < 2.4 diff --git a/src/Villefort/Config.hs b/src/Villefort/Config.hs --- a/src/Villefort/Config.hs +++ b/src/Villefort/Config.hs @@ -2,13 +2,16 @@ import System.Process import System.Environment.FindBin -import Villefort.Server +import Villefort.Definitions +import Villefort.Database def = VConfig { daily = [[]], monthly =[[]], yearly =[[]], weekly = defWeekly, - port = 3002 + port = 3002, + noCustom = False, + dataBasePath = Nothing } defWeekly = Weekly { diff --git a/src/Villefort/Database.hs b/src/Villefort/Database.hs --- a/src/Villefort/Database.hs +++ b/src/Villefort/Database.hs @@ -2,46 +2,52 @@ module Villefort.Database where import Control.Monad.IO.Class +import Control.Monad.Reader import Database.HDBC.Sqlite3 import Database.HDBC import Data.List.Split import System.Environment.FindBin import System.Environment import Paths_Villefort - +import Villefort.Definitions type Query = String type Path = String type Subject = String -getSubjects :: IO [Subject] +getSubjects :: (MonadReader VConfig m, MonadIO m) => m [Subject] getSubjects = (\x-> (!! 0) <$> x) <$> makeQuery "select Subject from todo where state = 0 group by Subject" --path =fmap (\x -> (x !! 0) ++ "Villefort.app/Contents/Resources/") $ (Data.List.Split.splitOn "Villefort.app") <$> getProgPath --path :: IO Path -path' :: IO FilePath +path' :: (MonadReader VConfig m, MonadIO m) => m FilePath path' = do - args <- getArgs + args <- liftIO $ getArgs if length args > 1 then if args !! 0 == "--custom" then return $ args !! 1 - else getDataDir - else getDataDir + else liftIO $ getDataDir + else liftIO $ getDataDir +getDb :: (MonadReader VConfig m, MonadIO m) => m Connection +--getDb = (++ "/data/todo.db") <$> liftIO path' >>= \path -> liftIO $ connectSqlite3 path -getDb :: IO Connection -getDb = (++ "/data/todo.db") <$> path' >>= \path -> connectSqlite3 path +getDb = do + path <- path' + let fullpath = (path ++ "/data/todo.db") + liftIO $ connectSqlite3 fullpath --convRow :: [[SqlValue]] -> [[String]] convRow dat = Prelude.map (\x -> Prelude.map (\y -> fromSql y :: String ) x) dat --makeQuery :: Query -> IO [[String]] +makeQuery :: (MonadReader VConfig m, MonadIO m) => String -> m [[String]] makeQuery query = do conn <- getDb - taskRaw <- quickQuery' conn query [] - disconnect conn + taskRaw <- liftIO $ quickQuery' conn query [] + liftIO $ disconnect conn return (convRow taskRaw) {- makeQuery query = getDb >>= \conn -> quickQuery' conn query [] >>= @@ -50,13 +56,45 @@ -} ---execQuery :: Query -> [Int] -> IO () -execQuery query params = getDb >>= \conn -> prepare conn query >>= +--execQuery :: (MonadReader VConfig m, MonadIO m) => Query -> [a] -> m () +execQuery query params = getDb >>= \conn -> liftIO $ prepare conn query >>= \stmt -> execute stmt ( map toSql params) >> commit conn >> disconnect conn -getNextId ::IO Integer +getNextId :: (MonadReader VConfig m, MonadIO m) => m Integer getNextId = do - f <-liftIO $ makeQuery "select id from todo order by id desc" + f <- makeQuery "select id from todo order by id desc" let rawid = head $ f let id = (read (rawid !! 0) :: Integer) +1 return id + + +delTask :: (MonadReader VConfig m, MonadIO m) => Int -> m () +delTask sqlId = execQuery "update todo set state = 0 where id = ?" [sqlId] + +updateTask :: (MonadReader VConfig m, MonadIO m) => Int -> Int -> m () +updateTask sqlId timeTaken = execQuery "insert into todo (id,Description,Title,Entered,Due,state,time,Subject) select id,Description,Title,Entered,datetime('now', 'localtime'),0,?,Subject from todo where id = ? limit 1" [ timeTaken, sqlId] + +addTask :: (MonadReader VConfig m, MonadIO m) => String -> String -> String -> String -> m () +addTask todoTitle todoSummary date todoSubject = do + nextSqlId <- getNextId + execQuery "insert into todo (id,Description,Title,Entered,Due,State,time,Subject) Values (?,?,?,datetime('now', 'localtime'),?,1,0,?)" [show nextSqlId, todoTitle, todoSummary, date, todoSubject] + return () + + +addDaily :: (MonadReader VConfig m, MonadIO m) => [String] -> m () +addDaily addD= do + lastRowId <- getNextId + execQuery "insert into todo (id,Description,Title,Entered,Due,State,time,Subject ) Values (?,?,?,current_date,current_date,1,0,?)" $ [show lastRowId] ++ addD + +getDone :: (MonadReader VConfig m, MonadIO m) => m [[String]] +getDone = makeQuery "select Title, time from todo where substr(Due,1,10) = Date('now','localtime') and time != 0" + +-- | Query to get average of subjects +--getAvg :: IO (Maybe [String]) +getAvg :: (MonadReader VConfig m, MonadIO m) => m [[String]] +getAvg = makeQuery "select avg(time), Subject from todo group by Subject order by avg(time) desc" + +-- | Query to get sum of subjects +--getSum :: IO (Maybe [String]) +getSum :: (MonadReader VConfig m, MonadIO m) => m [[String]] +getSum = makeQuery "select sum(time), Subject from todo group by Subject order by sum(time) desc" diff --git a/src/Villefort/Definitions.hs b/src/Villefort/Definitions.hs new file mode 100644 --- /dev/null +++ b/src/Villefort/Definitions.hs @@ -0,0 +1,23 @@ +module Villefort.Definitions where + +data VConfig = VConfig { + daily :: ![[String]], + monthly :: [[String]], + yearly :: [[String]], + weekly :: Weekly, + port :: Int, + noCustom :: Bool, + dataBasePath :: Maybe String + } + +data Weekly = Weekly { + monday :: [IO[String]], + tuesday :: [IO[String]], + wednesday :: [IO[String]], + thursday :: [IO[String]], + friday :: [IO[String]], + saturday :: [IO[String]], + sunday ::[IO[String]] + } + + diff --git a/src/Villefort/Server.hs b/src/Villefort/Server.hs --- a/src/Villefort/Server.hs +++ b/src/Villefort/Server.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module Villefort.Server where import Web.Scotty @@ -9,6 +10,7 @@ import Villefort.Database import Villefort.Todo import Villefort.Stats +import Villefort.Definitions import Paths_Villefort import Villefort.Daily import Villefort.Ml @@ -17,14 +19,14 @@ import System.IO.Strict as S import System.Environment import Control.Monad +import Control.Monad.Reader import System.Environment.FindBin import System.Process import System.Directory import System.FilePath import System.Posix.Process import Paths_Villefort - -getWeeks :: IO [[[Char]]] +getWeeks ::(MonadReader VConfig m,MonadIO m) => m [[[Char]]] getWeeks = do rawSql <- makeQuery "select id, Title from weeks where state = 1 order by Title" return $ Prelude.mapM (\x -> [Prelude.head x ,( Prelude.tail (Prelude.last x))]) rawSql @@ -44,12 +46,12 @@ -- | makes html for radiobutton makeRadio :: String -> String makeRadio x = "
" ++ x ++ "
\n" - -makeNewPage :: IO String + +makeNewPage :: (MonadReader VConfig m, MonadIO m) => m String makeNewPage = do - headerPath <- getDataFileName "templates/header" + headerPath <-liftIO $ getDataFileName "templates/header" htmlHeader <- liftIO $ S.readFile headerPath - addPath <- getDataFileName "templates/add.html" + addPath <- liftIO $ getDataFileName "templates/add.html" add <- liftIO $ S.readFile addPath let splitWeeks = splitOn "?" add subjects <- getSubjects @@ -58,26 +60,9 @@ -- | Main function of loop -data VConfig = VConfig { - daily :: ![[String]], - monthly :: [[String]], - yearly :: [[String]], - weekly :: Weekly, - port :: Int} -data Weekly = Weekly { - monday :: [IO[String]], - tuesday :: [IO[String]], - wednesday :: [IO[String]], - thursday :: [IO[String]], - friday :: [IO[String]], - saturday :: [IO[String]], - sunday ::[IO[String]] - } - - writeDate :: IO () writeDate = do date <- show <$> getDate @@ -111,12 +96,11 @@ checkYear :: D -> D -> Bool checkYear oldDate currentDate = (year oldDate) == (year currentDate) - runDaily vconf oldDate currentDate= if (checkDay oldDate currentDate) then putStrLn "same-day" else - putStrLn "adding-daily" >> putStrLn (show ( daily vconf)) >> mapM_ addDaily (daily vconf) + putStrLn "adding-daily" >> putStrLn (show ( daily vconf)) >> runReaderT ( mapM_ addDaily (daily vconf)) vconf runMonthly :: D -> D -> IO () runMonthly oldDate currentDate = if(checkMonth oldDate currentDate) then @@ -130,10 +114,6 @@ else putStrLn "adding yearly" -addDaily :: [String] -> IO () -addDaily addD= do - lastRowId <- getNextId - execQuery "insert into todo (id,Description,Title,Entered,Due,State,time,Subject ) Values (?,?,?,current_date,current_date,1,0,?)" $ [show lastRowId] ++ addD runWeekly :: VConfig -> Int -> Int -> IO () runWeekly conf old current = do @@ -143,7 +123,7 @@ stmts <- sequence stmt mapM_ add stmts else return () - where add = (\x -> if Prelude.null x then return () else addDaily x) + where add = (\x -> if Prelude.null x then return () else runReaderT ( addDaily x) conf) selector conf x | x == 0 = monday lookup @@ -158,6 +138,7 @@ + --man :: IO () man conf = do oldDate <- readDate @@ -176,10 +157,12 @@ villefort conf = do args <- getArgs case args of - ["--custom",x] -> putStrLn "custom" >> launch conf ["--recompile"] -> putStrLn "recompiling" >> recompile - _ ->do putStrLn "straight startign " >> checkCustomBuild >> launch conf + _ -> putStrLn "straight starting " >> do + if noCustom conf + then launch conf + else checkCustomBuild >> launch conf recompile :: IO () recompile = do @@ -206,16 +189,16 @@ _ <- forkIO dailyMl scotty ( port conf) $ do get "/" $ do - todos <- liftIO getTodos + todos <- liftIO $ runReaderT getTodos conf html $ pack $ todos get "/new" $ do - page <- liftIO makeNewPage + page <- liftIO $ runReaderT makeNewPage conf html $ pack page post "/delete" $ do rawHtml <- body - deleteTodo rawHtml + runReaderT (deleteTodo rawHtml) conf redirect "/" post "/update" $ do @@ -227,7 +210,7 @@ let rawtime = Data.List.Split.splitOn "=" $ (da !! 0) do liftIO $ print rawtime let insertTime = read (rawtime !! 1) :: Int - do liftIO $ updateTask sqlId insertTime + do liftIO $ runReaderT (updateTask sqlId insertTime) conf redirect "/" post "/add" $ do @@ -239,11 +222,11 @@ let date = convDate $ getIndex parse 3 let todoTitle = rep $ getIndex parse 1 let todoSubject = rep $ getIndex parse 2 - liftIO $ addTask todoTitle summary date todoSubject + liftIO $ runReaderT (addTask todoTitle summary date todoSubject) conf redirect "/" get "/time" $ do - dat <-liftIO $ getSummary + dat <-liftIO $ runReaderT getSummary conf html $ pack dat @@ -253,6 +236,6 @@ file jsPath get "/stat" $ do - page <- liftIO $ genStats + page <- liftIO $runReaderT genStats conf html $ pack page diff --git a/src/Villefort/Stats.hs b/src/Villefort/Stats.hs --- a/src/Villefort/Stats.hs +++ b/src/Villefort/Stats.hs @@ -1,22 +1,16 @@ +{-# LANGUAGE FlexibleContexts #-} module Villefort.Stats (genStats, makeTable )where import Villefort.Database import Control.Monad.IO.Class +import Control.Monad.Reader +import Villefort.Definitions import Paths_Villefort import System.Random --- | Query to get average of subjects ---getAvg :: IO (Maybe [String]) -getAvg :: IO [[String]] -getAvg = makeQuery "select avg(time), Subject from todo group by Subject order by avg(time) desc" --- | Query to get sum of subjects ---getSum :: IO (Maybe [String]) -getSum :: IO [[String]] -getSum = makeQuery "select sum(time), Subject from todo group by Subject order by sum(time) desc" - -- | Helper function to generate row of table makeRow :: [String] -> String makeRow x = " " ++ (x !! 0) ++ " " ++ (x!! 1) ++ " " @@ -26,19 +20,13 @@ makeTable tableData stats = " " ++ "" ++ ( makeRow tableData) ++ "" ++ (mconcat (map makeRow stats)) ++ "
" -- | Generate stats -{- -genStats :: IO String -genStats = getSubjects >>= \subjects -> mapM makeGithub subjects >>= \gits -> getAvg >>= - \avg -> getSum >>= \statsSum -> getDataFileName "templates/header" >>= \x -> liftIO (readFile x) >>= \header -> return (header ++ table ++ (makeTable ["Subject","time"] avg) ++ "

Sum

" ++ (makeTable ["Subject","time"] statsSum) ++ "" ++ (mconcat gits)) --} - -genStats :: IO String +genStats :: (MonadReader VConfig m, MonadIO m) => m String genStats = do subjects <- getSubjects - gits <- mapM makeGithub subjects + gits <- mapM makeGithub subjects avg <- getAvg statsSum <- getSum - x <- getDataFileName "templates/header" + x <- liftIO $ getDataFileName "templates/header" header <- liftIO (readFile x) return (header ++ table ++ (makeTable ["Subject","time"] avg) ++ "

Sum

" ++ (makeTable ["Subject","time"] statsSum) ++ "" ++ (mconcat gits)) @@ -49,10 +37,10 @@ -- | creates the github like graph from database -makeGithub :: String -> IO String +makeGithub ::(MonadReader VConfig m, MonadIO m) => String -> m Subject makeGithub subject = do - z <- makeQuery ("select substr(Due,1,10) from todo where subject = '" ++ subject ++ "' and state = 0") - color <- getColor + z <- makeQuery ("select substr(Due,1,10) from todo where subject = '" ++ subject ++ "' and state = 0") + color <- liftIO $ getColor let header = "

Calendar "++ subject ++ "

" diff --git a/src/Villefort/Summary.hs b/src/Villefort/Summary.hs --- a/src/Villefort/Summary.hs +++ b/src/Villefort/Summary.hs @@ -1,15 +1,15 @@ +{-# LANGUAGE FlexibleContexts #-} module Villefort.Summary where import Villefort.Database -import Control.Monad.IO.Class +import Control.Monad.Reader import Villefort.Todo import Villefort.Stats +import Villefort.Definitions -getDone :: IO [[String]] -getDone = makeQuery "select Title, time from todo where substr(Due,1,10) = Date('now','localtime') and time != 0" -getSummary :: IO String +getSummary :: (MonadReader VConfig m, MonadIO m) => m String getSummary = do - dat <- liftIO $ getDone - header <- getHeader + dat <- getDone + header <- liftIO $ getHeader return ( header ++ (makeTable ["Subject","Time"] dat)) --2017-07-26 diff --git a/src/Villefort/Todo.hs b/src/Villefort/Todo.hs --- a/src/Villefort/Todo.hs +++ b/src/Villefort/Todo.hs @@ -1,11 +1,15 @@ +{-# LANGUAGE FlexibleContexts #-} module Villefort.Todo where import Villefort.Database import Villefort.Time +import Villefort.Definitions import Control.Monad.IO.Class import Data.List.Split +import Data.ByteString.Lazy hiding (map,length,take,readFile) import Paths_Villefort import Database.HDBC +import Control.Monad.Reader data Row = Row { rid :: Int, @@ -20,7 +24,7 @@ toRow :: [String] -> Row toRow x = Row (read (x !! 0) :: Int) (x !! 1) (x !! 2) (x !! 3)( x !! 4) (read ( x !! 5) :: Int) (read (x !! 6) :: Double) -qetTasks' :: IO [Row] +qetTasks' :: (MonadReader VConfig m, MonadIO m) => m [Row] qetTasks' = do x <- makeQuery' "select id, Title, Description, Due, Subject, sum(time),pred from todo where state=1 group by id order by id" return (map toRow x) @@ -35,11 +39,11 @@ Nothing -> "0" --makeQuery :: Query -> IO [[String]] -makeQuery' :: String -> IO [[String]] +makeQuery' :: (MonadReader VConfig m, MonadIO m) => String -> m [[String]] makeQuery' query = do conn <- getDb - taskRaw <- quickQuery' conn query [] - disconnect conn + taskRaw <- liftIO $ quickQuery' conn query [] + liftIO $ disconnect conn return (convRow' taskRaw) @@ -103,12 +107,12 @@ -- | Returns html from todos -getTodos :: IO String +getTodos :: (MonadReader VConfig m, MonadIO m) => m String getTodos = do tasks <- qetTasks' --do liftIO $ putStrLn $ show tasks - modals <- sequence $ genModal' <$> tasks - header <- getHeader + modals <-liftIO $ sequence $ genModal' <$> tasks + header <- liftIO $ getHeader let body = Prelude.concat modals return (header ++ body) @@ -120,7 +124,7 @@ -- | Delete a done task from database sets state = 0 but it's record is still maintained in the database for the stats page. -deleteTodo :: (Show t, MonadIO m) => t -> m () +deleteTodo :: (MonadReader VConfig m, MonadIO m) => ByteString -> m () deleteTodo raw = do let da = Data.List.Split.splitOn "&" (show raw) let rawid = Data.List.Split.splitOn "=" $ (Prelude.init (da !! 1)) @@ -128,21 +132,8 @@ let rawtime = Data.List.Split.splitOn "=" $ (da !! 0) let integerTime = read (rawtime !! 1) :: Int if integerTime /= 0 then - do liftIO $ updateTask sqlId integerTime -- update task time - liftIO $ delTask sqlId -- then remove from database - else do liftIO $ delTask sqlId -- otherwise just remove from database + do updateTask sqlId integerTime -- update task time + delTask sqlId -- then remove from database + else delTask sqlId -- otherwise just remove from database return () - - -delTask :: Int -> IO () -delTask sqlId = execQuery "update todo set state = 0 where id = ?" [sqlId] - -updateTask :: Int -> Int -> IO () -updateTask sqlId timeTaken = execQuery "insert into todo (id,Description,Title,Entered,Due,state,time,Subject) select id,Description,Title,Entered,datetime('now', 'localtime'),0,?,Subject from todo where id = ? limit 1" [ timeTaken, sqlId] - -addTask :: String -> String -> String -> String -> IO () -addTask todoTitle todoSummary date todoSubject = do - nextSqlId <- getNextId - execQuery "insert into todo (id,Description,Title,Entered,Due,State,time,Subject) Values (?,?,?,datetime('now', 'localtime'),?,1,0,?)" [show nextSqlId, todoTitle, todoSummary, date, todoSubject] - return () diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,24 +1,9 @@ -import Test.QuickCheck -import Test.QuickCheck.Monadic ---import Test.QuickCheck.Batch -main :: IO () -main = quickCheck prop_commutativeAdd +import System.Exit (exitFailure) +import Control.Concurrent +import Villefort -prop_commutativeAdd :: Integer -> Integer -> Bool -prop_commutativeAdd n m = n + m == m + n -{- ---prop_data :: String -> String -> String -> String -> Bool -dat :: String -> String -> String -> String -> IO Bool -dat w x y z = do - addTask w x y z - list <- qetTasks' - let f = last list - --putStrLn $ show f - --putStrLn $ show $ [w,x,y,z] - return ([title f, description f, due f, subject f] == [w,x,y,z]) +main :: IO () +main = do forkIO (villefort def {port = 999,noCustom = True}) >> do + putStrLn "started server" -prop_dat w x y z = monadicIO $ do - date <- run (dat w x y z) - assert date --}