Villefort 0.1.1.4 → 0.1.1.5

raw patch · 9 files changed

+144/−131 lines, 9 filesdep +bytestringdep −QuickCheckdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring

Dependencies removed: QuickCheck

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Villefort.cabal +6/−4
• src/Villefort/Config.hs +5/−2
• src/Villefort/Database.hs +52/−14
• src/Villefort/Definitions.hs +23/−0
• src/Villefort/Server.hs +22/−39
• src/Villefort/Stats.hs +9/−21
• src/Villefort/Summary.hs +6/−6
• src/Villefort/Todo.hs +15/−24
• test/Spec.hs +6/−21

@@ -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                      

@@ -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 {

@@ -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"

@@ -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]]+                     }++

@@ -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 =  "<dd><input type='radio' name='subject' value='"++ x ++ "'> " ++ x ++ "</br> \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       

@@ -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 =  "<tr> <th>" ++ (x !! 0) ++ "</th> <th>  " ++ (x!! 1) ++ "</th> </tr>"@@ -26,19 +20,13 @@ makeTable tableData stats = "<table class='table' style='width:100%'> "  ++ "<thead class='thead-inverse'>" ++ ( makeRow  tableData) ++ "</thead>" ++ (mconcat (map  makeRow stats)) ++ "</table>"  -- | 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) ++ "</br> <h1> Sum </h1>" ++ (makeTable ["Subject","time"] statsSum) ++ "</html>" ++ (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) ++ "</br> <h1> Sum </h1>" ++ (makeTable ["Subject","time"] statsSum) ++ "</html>" ++ (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 = "<h2 id='"++ subject ++ "'> Calendar "++ subject ++ " </h2> <script> new Calendar({ append_to: '" ++ subject ++ "',num_weeks: 51,day_size: 11, data: ["   let q = Prelude.map (\x -> "['" ++ (x !! 0) ++"',500],") z   let bot = "  ], color: " ++ color ++ " }); </script>"

@@ -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

@@ -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 () 

@@ -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--}