diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Villefort +import System.Random + +main :: IO () +main = villefort def diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,35 @@ # Villefort Villefort is a time managment system written in Haskell. -## What's new in version Villefort-0.1.0.8 -- Pretty colors on the stats page. -- Fixed time tracking bug. -- Better UX on the home page. +## Now with xmonad style configuration! +You can Configure +-- the port +-- daily tasks +-- tasks to run on certain days of the week. + +create a custom main method in ~.villefort/villefort.hs example + +```haskell +module Main where + +import Villefort + + +main :: IO () +main = villefort def { + -- description Title Subject + daily = [[ "Water Plants with 50ml of water","Water Plants","Garden"]] -- tasks to run daily + weekly = defWeekly { + friday = [return ["Freaky Friday","Friday","Admin"] -- tasks to run every friday + }, + port = 3001 + } +``` + +Then run ```Villefort --recompile``` +the next time you run villefort it will run with your configuration. + +The default configuration is located here https://github.com/Chrisr850/Villefort/blob/master/src/Villefort/Config.hs # Home screen ![alt text](https://raw.githubusercontent.com/Chrisr850/Villefort/master/data/screen.png) diff --git a/Villefort.cabal b/Villefort.cabal --- a/Villefort.cabal +++ b/Villefort.cabal @@ -1,5 +1,5 @@ name: Villefort -version: 0.1.0.8 +version: 0.1.1.0 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,7 +12,8 @@ build-type: Simple extra-source-files: README.md cabal-version: >=1.10 -data-files: data/todo.db +data-files: data/date + , data/day , templates/*.html , templates/*.ts , templates/header @@ -21,9 +22,17 @@ library hs-source-dirs: src other-modules: Paths_Villefort - exposed-modules: Database - , Todo - , Stats + ghc-options: -Wall + exposed-modules: Villefort + , Villefort.Todo + , Villefort.Database + , Villefort.Stats + , Villefort.Time + , Villefort.Daily + , Villefort.Ml + , Villefort.Summary + , Villefort.Config + , Villefort.Server build-depends: base >= 4.9 && < 5 , HDBC >= 2.4.0 && < 2.5 , HDBC-sqlite3 >= 2.3.3 && < 2.4 @@ -32,14 +41,20 @@ , FindBin >= 0.0.5 && < 0.1 , mtl >= 2.2.1 && < 2.3 , random - + , process + , strict + , scotty + , text + , directory + , filepath + , unix + , transformers default-language: Haskell2010 executable Villefort - hs-source-dirs: app main-is: Main.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fwarn-unused-binds -Wall other-modules: Paths_Villefort build-depends: base , Villefort @@ -49,6 +64,7 @@ , split , text , time + , random default-language: Haskell2010 test-suite Villefort-test @@ -57,6 +73,11 @@ main-is: Spec.hs build-depends: base , Villefort + , QuickCheck + , HDBC >= 2.4.0 && < 2.5 + , HDBC-sqlite3 >= 2.3.3 && < 2.4 + + ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Web.Scotty -import Data.Char -import Control.Monad.IO.Class -import Database.HDBC.Sqlite3 -import Database.HDBC -import Data.List.Split -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Text.Lazy hiding (splitOn,map,concat,head) -import Data.Time -import Database -import Todo -import Stats -import Paths_Villefort - - - -getDone = makeQuery "select Title, time from todo where due = Date('now','localtime') and state = 0" - -getWeeks = do - raw <- makeQuery "select id, Title from weeks where state = 1 order by Title" - return $ Prelude.mapM (\x -> [Prelude.head x ,( Prelude.tail (Prelude.last x))]) raw - - -getIndex :: [[Char]] -> Int -> [Char] -getIndex str i = (Data.List.Split.splitOn "=" (str !! i)) !! 1 - - --- | Converts date from Javascript to sqlite date fromat -convDate :: String -> String -convDate date = newDate - where split = Data.List.Split.splitOn "%2F" date - newDate = (split !! 2) ++ "-" ++ (split !! 0) ++ "-" ++ (split !! 1) - - --- | makes html for radiobutton -makeRadio x = "
" ++ x ++ "
\n" - - -makeNewPage = do - headerPath <- getDataFileName "templates/header" - header <- liftIO $ readFile headerPath - addPath <- getDataFileName "templates/add.html" - add <- liftIO $ readFile addPath - let split = splitOn "?" add - subjects <- getSubjects - let radiobuttons = map makeRadio subjects - return (header ++ (split !! 0) ++ (concat radiobuttons) ++ (split !! 1)) - --- | Main function of loop -main :: IO () -main = do - scotty 3002 $ do - get "/" $ do - todos <- liftIO getTodos - html $ pack $ todos - - get "/new" $ do - page <- liftIO makeNewPage - html $ pack page - - post "/delete" $ do - raw <- body - deleteTodo raw - redirect "/" - - post "/update" $ do - raw <- body - let da = Data.List.Split.splitOn "&" (show raw) - do liftIO $ print $ show da - let rawid = Data.List.Split.splitOn "=" $ (Prelude.init (da !! 1)) - let id = read (rawid!! 1) :: Int - let rawtime = Data.List.Split.splitOn "=" $ (da !! 0) - do liftIO $ print rawtime - let time = read (rawtime !! 1) :: Int - do liftIO $ updateTask id time - redirect "/" - - post "/add" $ do - raw <-body - conn <- liftIO $ getDb - let parse = Data.List.Split.splitOn "&" (show raw) - do liftIO $ print parse - let rep y = map (\x -> if x == '+' then ' ' else x) y - let summary = rep $ getIndex parse 0 - let date = convDate $ getIndex parse 3 - let title = rep $ getIndex parse 1 - let subject = rep $ getIndex parse 2 - f <-liftIO $ makeQuery "select id from todo order by id desc" - let rawid = head $ f - let id = (read (rawid !! 0) :: Integer) +1 - stmt <- liftIO $ prepare conn "insert into todo (id,Description,Title,Entered,Due,State,time,Subject) Values (?,?,?,current_date,?,1,0,?)" - do liftIO $ execute stmt [toSql id,toSql title,toSql summary,toSql date,toSql subject] - do liftIO $ commit conn - do liftIO $ disconnect conn - redirect "/" - - - get "/time" $ do - dat <- liftIO $ getDone - html $ pack $ ("

Shit I've done today

" ++ (show dat)) - - - - get "/js-chart-widgets.min.js" $ do - path <- liftIO $ getDataFileName "js.js" - file path - - get "/stat" $ do - page <- liftIO $ genStats - html $ pack page diff --git a/data/date b/data/date new file mode 100644 --- /dev/null +++ b/data/date @@ -0,0 +1,1 @@ +2017-06-05 diff --git a/data/day b/data/day new file mode 100644 --- /dev/null +++ b/data/day @@ -0,0 +1,1 @@ +1 diff --git a/data/todo.db b/data/todo.db deleted file mode 100644 Binary files a/data/todo.db and /dev/null differ diff --git a/src/Database.hs b/src/Database.hs deleted file mode 100644 --- a/src/Database.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Database where - -import Control.Monad.IO.Class -import Control.Monad.State.Strict -import Database.HDBC.Sqlite3 -import Database.HDBC -import Data.List.Split -import System.Environment.FindBin -import Paths_Villefort - -type Query = String -type Path = String -type Subject = String - - ---getSubjects :: IO (Maybe [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 =fmap (\x -> (x !! 0) ++ "Villefort/") $ (Data.List.Split.splitOn "Villefort/") <$> getProgPath ---path = getDataDir - -path' = getDataDir - -getDb :: IO Connection -getDb = (++ "/data/todo.db") <$> path' >>= \path -> putStrLn path >> connectSqlite3 path - ---convRow :: [[SqlValue]] -> [[String]] -convRow dat = Prelude.map (\x -> Prelude.map (\y -> fromSql y :: String ) x) dat - - ---makeQuery :: Query -> IO [[String]] -makeQuery query = do - conn <- getDb - taskRaw <- quickQuery' conn query [] - disconnect conn - return (convRow taskRaw) - {- -makeQuery query = getDb >>= \conn -> quickQuery' conn query [] >>= - \taskRaw -> disconnect conn >> return ( convRow taskRaw) - --} - - -execQuery :: Query -> [Int] -> IO () -execQuery query params = getDb >>= \conn -> prepare conn query >>= - \stmt -> execute stmt ( map toSql params) >> commit conn >> disconnect conn diff --git a/src/Stats.hs b/src/Stats.hs deleted file mode 100644 --- a/src/Stats.hs +++ /dev/null @@ -1,69 +0,0 @@ -module Stats (genStats - )where -import Database -import Control.Monad.IO.Class -import Paths_Villefort -import System.Random - -data Query = Query String - --- | Query to get average of subjects ---getAvg :: IO (Maybe [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 = makeQuery "select sum(time), Subject from todo group by Subject order by sum(time) desc" - --- | Helper function to generate row of table -makeRow x = " " ++ (x !! 0) ++ " " ++ (x!! 1) ++ " " - --- | Generate Table -makeTable stats = "" ++ (mconcat (map makeRow stats)) ++ "
" - --- | Generate stats - - -genStats = getSubjects >>= \x -> mapM makeGithub x >>= \gits -> getAvg >>= - \avg -> getSum >>= \sum -> getDataFileName "templates/header" >>= \x -> liftIO (readFile x) >>= \head -> return (head ++ table ++ (makeTable avg) ++ "

Sum

" ++ (makeTable sum) ++ "" ++ (mconcat gits)) --- | Library to include for github table -table :: String -table = "

avg

" - --- | creates the github like graph from database - - ---makeGithub :: Maybe String -> IO String -makeGithub subject = do - z <- makeQuery ("select Due from todo where subject = '" ++ subject ++ "' and state = 0") - color <- getColor - let head = "

Calendar "++ subject ++ "

" - return (head ++ (Prelude.concat q )++ bot) - -colors = ["'#F44336'" - ,"'#E91E63'" - ,"'#9C27B0'" - ,"'#673AB7'" - ,"'#3F51B5'" - ,"'#2196F3'" - ,"'#03A9F4'" - ,"'#00BCD4'" - ,"'#009688'" - ,"'#4CAF50'" - ,"'#8BC34A'" - ,"'#CDDC39'" - ,"'#FFEB3B'" - ,"'#FFC107'" - ,"'#FF9800'" - ,"'#FF5722'" - ,"'#795548'" - ,"'#9E9E9E'" - ,"'#607D8B'" - ] - -getColor = do - number <- randomRIO (0, (length $ colors)-1) :: IO Int - return (colors !! number) - diff --git a/src/Todo.hs b/src/Todo.hs deleted file mode 100644 --- a/src/Todo.hs +++ /dev/null @@ -1,149 +0,0 @@ -module Todo (getTodos - ,updateTask - ,deleteTodo - ,qetTasks' - ,makeQuery' - ,conv' - ,convRow' - ,genModal' - ) where - -import Database -import Data.List.Split -import Control.Monad.IO.Class -import Data.Time -import Data.List.Split as S -import Paths_Villefort -import Database.HDBC.Sqlite3 -import Database.HDBC - - -data Row = Row { rid :: Int, - title :: String, - description :: String, - due :: String, - time :: Int - } deriving (Show) - ---toRow :: Maybe [String] -> Maybe Row -toRow x = Row (read (x !! 0) :: Int) (x !! 1) (x !! 2) (x !! 3) (read( x !! 4) :: Int) - -qetTasks' = do - -- I would like to take this moment to personally apoligize to the sql gods for creating this monstrosity. - x <- makeQuery' "select id, Title, Description, Due, sum(time) from todo where state=1 group by id " - return (map toRow x) - -convRow' dat = Prelude.map (\x -> Prelude.map (\y -> conv' y ) x) dat - ---conv :: SqlValue -> String -conv' x = case fromSql x of - Just x -> fromSql x :: String - Nothing -> "1" - - ---makeQuery :: Query -> IO [[String]] -makeQuery' query = do - conn <- getDb - taskRaw <- quickQuery' conn query [] - disconnect conn - return (convRow' taskRaw) - - -merge [] ys = ys -merge (x:xs) ys = x:merge ys xs - - - -genModal' row = if rid row == 1 then return (" ") else do - let f = due row - modal <- getModal - days <- daysTilDue f - let da = [daysToColor' days , - show $ rid row, - (convTitle $ title row) ++ "Due in " ++ show days, - show $ rid row, - title row, - description row, - show $ time row, - "/delete", - show $ rid row - ] - - return $ mconcat $ merge modal da - - ---genModal row = - -daysToColor' x = if x < 1 then "btn-due0" - else if x == 1 then "btn-due1" - else if x == 2 then "btn-due2" - else if x == 3 then "btn-due3" - else if x == 4 then "btn-due4" - else if x == 5 then "btn-due5" - else if x == 6 then "btn-due6" - else "btn-due7" - - - - -convTitle title - | length s1 > 30 = s1 - | length s2 > 30 = s2 - | length s3 > 30 = s3 - | length s4 > 30 = s4 - | otherwise = title - where split = (Data.List.Split.splitOn "." title) - s1 = (split !! 0) - s2 = mconcat (take 2 split) - s3 = mconcat (take 3 split) - s4 = mconcat (take 4 split) - - -getModal :: IO [[Char]] ---getModal = path >>= \path -> readFile (path ++ "templates/modal.ts") >>= \rawModal -> return (Data.List.Split.splitOn "}" rawModal) -getModal = getDataFileName "templates/modal.ts" >>= \path -> readFile path>>= \rawModal -> return (Data.List.Split.splitOn "}" rawModal) - -daysTilDue date = do - c <- getCurrentTime - let (y,m,d) = toGregorian $ utctDay c - let split = Data.List.Split.splitOn "-" date - current <- fromZonedTimeToDay <$> show <$> getZonedTime - let due = fromGregorian (read (split !! 0) :: Integer) (read (split !! 1) :: Int) (read (split !! 2) :: Int) - return $ (diffDays due current) - -fromZonedTimeToDay x = fromGregorian (read (nums !! 0) :: Integer) (read (nums !! 1) :: Int) (read (nums !! 2) :: Int) - where nums = S.splitOn "-" $ take 10 x - --- | Returns html from todos -getTodos = do - tasks <- qetTasks' - do liftIO $ putStrLn $ show tasks - path <- path - modals <- sequence $ genModal' <$> tasks - headerPath <- getDataFileName "templates/header" - header <- liftIO $ readFile headerPath - let body = Prelude.concat modals - return (header ++ body) - --- | Delete a done task from database sets state = 0 but it's record is still maintained in the database for the stats page. -deleteTodo raw = do - let da = Data.List.Split.splitOn "&" (show raw) - let rawid = Data.List.Split.splitOn "=" $ (Prelude.init (da !! 1)) - let id = read (rawid!! 1) :: Int - let rawtime = Data.List.Split.splitOn "=" $ (da !! 0) - let time = read (rawtime !! 1) :: Int - do liftIO $ delTask id - do liftIO $ addTime id time - return () - - -addTime :: Int -> Int -> IO () -addTime id time = execQuery "update todo set time = ? where id = ?" [time,id] - -delTask :: Int -> IO () -delTask id = execQuery "update todo set state = 0 where id = ?" [id] - -updateTask :: Int -> Int -> IO () -updateTask id time = execQuery "insert into todo (id,Description,Title,Entered,Due,state,time,Subject) select id,Description,Title,Entered,Due,1,?,Subject from todo where id = ? limit 1" [ time, id] - - diff --git a/src/Villefort.hs b/src/Villefort.hs new file mode 100644 --- /dev/null +++ b/src/Villefort.hs @@ -0,0 +1,6 @@ +module Villefort ( +module Villefort.Server, +module Villefort.Config + ) where +import Villefort.Server +import Villefort.Config diff --git a/src/Villefort/Config.hs b/src/Villefort/Config.hs new file mode 100644 --- /dev/null +++ b/src/Villefort/Config.hs @@ -0,0 +1,24 @@ + module Villefort.Config where + +import System.Process +import System.Environment.FindBin +import Villefort.Server +def = VConfig { + daily = [[]], + monthly =[[]], + yearly =[[]], + weekly = defWeekly, + port = 3002 + } + +defWeekly = Weekly { + monday = [return []], + tuesday =[return[]], + wednesday = [return[]], + thursday = [return[]], + friday = [return[]], + saturday = [return[]], + sunday = [return []] + } + +-- ghc -o /home/chris/.villefort/villefort /home/chris/.villefort/villefort.hs diff --git a/src/Villefort/Daily.hs b/src/Villefort/Daily.hs new file mode 100644 --- /dev/null +++ b/src/Villefort/Daily.hs @@ -0,0 +1,7 @@ +module Villefort.Daily where +import Villefort.Time +import Villefort.Database +import Control.Concurrent +import Control.Monad +import System.IO.Strict as S +import Paths_Villefort diff --git a/src/Villefort/Database.hs b/src/Villefort/Database.hs new file mode 100644 --- /dev/null +++ b/src/Villefort/Database.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleContexts #-} +module Villefort.Database where + +import Control.Monad.IO.Class +import Database.HDBC.Sqlite3 +import Database.HDBC +import Data.List.Split +import System.Environment.FindBin +import System.Environment +import Paths_Villefort + +type Query = String +type Path = String +type Subject = String + + +getSubjects :: IO [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' = do + args <- getArgs + if args !! 0 == "--custom" + then return $ args !! 1 + else getDataDir + +getDb :: IO Connection +getDb = (++ "/data/todo.db") <$> path' >>= \path -> connectSqlite3 path + +--convRow :: [[SqlValue]] -> [[String]] +convRow dat = Prelude.map (\x -> Prelude.map (\y -> fromSql y :: String ) x) dat + + +--makeQuery :: Query -> IO [[String]] +makeQuery query = do + conn <- getDb + taskRaw <- quickQuery' conn query [] + disconnect conn + return (convRow taskRaw) + {- +makeQuery query = getDb >>= \conn -> quickQuery' conn query [] >>= + \taskRaw -> disconnect conn >> return ( convRow taskRaw) + +-} + + +--execQuery :: Query -> [Int] -> IO () +execQuery query params = getDb >>= \conn -> prepare conn query >>= + \stmt -> execute stmt ( map toSql params) >> commit conn >> disconnect conn + +getNextId ::IO Integer +getNextId = do + f <-liftIO $ makeQuery "select id from todo order by id desc" + let rawid = head $ f + let id = (read (rawid !! 0) :: Integer) +1 + return id diff --git a/src/Villefort/Ml.hs b/src/Villefort/Ml.hs new file mode 100644 --- /dev/null +++ b/src/Villefort/Ml.hs @@ -0,0 +1,19 @@ +module Villefort.Ml where + +import System.Process +import Control.Monad +import Control.Concurrent + +train :: IO () +train = do + callCommand "/home/chris/Haskell/Villefort/ml/Train.py" >> putStrLn "train" +predict :: IO () +predict = do + callCommand"/home/chris/Haskell/Villefort/ml/Predict.py" >> putStrLn "predict" +ml :: IO () +ml = do + -- predict + threadDelay 18000000 + +dailyMl :: IO () +dailyMl = forever ml diff --git a/src/Villefort/Server.hs b/src/Villefort/Server.hs new file mode 100644 --- /dev/null +++ b/src/Villefort/Server.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE OverloadedStrings #-} +module Villefort.Server where + +import Web.Scotty +import Control.Monad.IO.Class +import Control.Concurrent +import Data.List.Split +import Data.Text.Lazy hiding (splitOn,map,concat,head) +import Villefort.Database +import Villefort.Todo +import Villefort.Stats +import Paths_Villefort +import Villefort.Daily +import Villefort.Ml +import Villefort.Time +import Villefort.Summary +import System.IO.Strict as S +import System.Environment +import Control.Monad +import System.Environment.FindBin +import System.Process +import System.Directory +import System.FilePath +import System.Posix.Process +import Paths_Villefort +getWeeks :: IO [[[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 + + +getIndex :: [[Char]] -> Int -> [Char] +getIndex str i = (Data.List.Split.splitOn "=" (str !! i)) !! 1 + + +-- | Converts date from Javascript to sqlite date fromat +convDate :: String -> String +convDate date = newDate + where splitDate = Data.List.Split.splitOn "%2F" date + newDate = (splitDate !! 2) ++ "-" ++ (splitDate !! 0) ++ "-" ++ (splitDate !! 1) + + +-- | makes html for radiobutton +makeRadio :: String -> String +makeRadio x = "
" ++ x ++ "
\n" + +makeNewPage :: IO String +makeNewPage = do + headerPath <- getDataFileName "templates/header" + htmlHeader <- liftIO $ S.readFile headerPath + addPath <- getDataFileName "templates/add.html" + add <- liftIO $ S.readFile addPath + let splitWeeks = splitOn "?" add + subjects <- getSubjects + let radiobuttons = map makeRadio subjects + return (htmlHeader ++ (splitWeeks !! 0) ++ (concat radiobuttons) ++ (splitWeeks !! 1)) + +-- | 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 + datePath <- getDataFileName "data/date" + writeFile datePath date + +readDate :: IO D +readDate = do + datePath <- getDataFileName "data/date" + raw <- S.readFile datePath + let date = unpackStringToDate raw + return date + +writeDay :: IO () +writeDay = do + day <- show <$> getDay + datePath <- getDataFileName "data/day" + writeFile datePath day + +readDay :: IO Int +readDay = do + datePath <- getDataFileName "data/day" + raw <- S.readFile datePath + let int = read raw :: Int + return int + +checkDay :: D -> D ->Bool +checkDay oldDate currentDate= ((day oldDate) == (day currentDate)) +checkMonth :: D -> D -> Bool +checkMonth oldDate currentDate = (month oldDate) == (month currentDate) +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) + +runMonthly :: D -> D -> IO () +runMonthly oldDate currentDate = if(checkMonth oldDate currentDate) then + putStrLn "same-month" + else + putStrLn "adding monthly" + +runYearly :: D -> D -> IO () +runYearly oldDate currentDate = if(checkYear oldDate currentDate) then + putStrLn "same-year" + 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 + if old /= current + then do + let stmt = selector conf (current-1) + stmts <- sequence stmt + mapM_ add stmts + else return () + where add = (\x -> if Prelude.null x then return () else addDaily x) + +selector conf x + | x == 0 = monday lookup + | x == 1 = tuesday lookup + | x == 2 = wednesday lookup + | x == 3 = thursday lookup + | x == 4 = friday lookup + | x == 5 = saturday lookup + | otherwise = sunday lookup + where lookup = weekly conf + + + + +--man :: IO () +man conf = do + oldDate <- readDate + currentDate <- getDateD + oldDay <- readDay + currentDay <- getDay + runWeekly conf oldDay currentDay + runDaily conf oldDate currentDate + writeDate + writeDay + threadDelay 18000000 + + +dailyCheck conf = forever$ man conf + +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 + +recompile :: IO () +recompile = do + dir <- getAppUserDataDirectory "villefort" + let execPath = dir ++ "/villefort" + sourcePath = dir ++"/villefort.hs" + (_,_,_,pid) <- createProcess (proc "/usr/bin/ghc" ["-o",execPath,sourcePath]) + waitForProcess pid + return () + +checkCustomBuild = do + dir <- getAppUserDataDirectory "villefort" + let path = dir ++ "/villefort" + putStrLn path + isBuild <- doesFileExist path + dataDir <- getDataDir + if isBuild + then putStrLn "custom buil detected" >> executeFile path True ["--custom",dataDir] Nothing + else putStrLn "no custom build :(" + +launch :: VConfig -> IO () +launch conf = do + _ <- forkIO $ dailyCheck conf + _ <- forkIO dailyMl + scotty ( port conf) $ do + get "/" $ do + todos <- liftIO getTodos + html $ pack $ todos + + get "/new" $ do + page <- liftIO makeNewPage + html $ pack page + + post "/delete" $ do + rawHtml <- body + deleteTodo rawHtml + redirect "/" + + post "/update" $ do + rawHtml <- body + let da = Data.List.Split.splitOn "&" (show rawHtml) + do liftIO $ print $ show da + let rawid = Data.List.Split.splitOn "=" $ (Prelude.init (da !! 1)) + let sqlId = read (rawid!! 1) :: Int + let rawtime = Data.List.Split.splitOn "=" $ (da !! 0) + do liftIO $ print rawtime + let insertTime = read (rawtime !! 1) :: Int + do liftIO $ updateTask sqlId insertTime + redirect "/" + + post "/add" $ do + rawBody <-body + let parse = Data.List.Split.splitOn "&" (show rawBody) + do liftIO $ print parse + let rep y = map (\x -> if x == '+' then ' ' else x) y + let summary = rep $ getIndex parse 0 + let date = convDate $ getIndex parse 3 + let todoTitle = rep $ getIndex parse 1 + let todoSubject = rep $ getIndex parse 2 + liftIO $ addTask todoTitle summary date todoSubject + redirect "/" + + get "/time" $ do + dat <-liftIO $ getSummary + html $ pack dat + + + + get "/js-chart-widgets.min.js" $ do + jsPath <- liftIO $ getDataFileName "js.js" + file jsPath + + get "/stat" $ do + page <- liftIO $ genStats + html $ pack page + diff --git a/src/Villefort/Stats.hs b/src/Villefort/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Villefort/Stats.hs @@ -0,0 +1,87 @@ +module Villefort.Stats (genStats, + makeTable + )where + +import Villefort.Database +import Control.Monad.IO.Class +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) ++ " " + +-- | Generate Table +makeTable ::[String] -> [[String]] -> String +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 = do + subjects <- getSubjects + gits <- mapM makeGithub subjects + avg <- getAvg + statsSum <- getSum + x <- getDataFileName "templates/header" + header <- liftIO (readFile x) + return (header ++ table ++ (makeTable ["Subject","time"] avg) ++ "

Sum

" ++ (makeTable ["Subject","time"] statsSum) ++ "" ++ (mconcat gits)) + + +-- | Library to include for github table +table :: String +table = "

avg

" + +-- | creates the github like graph from database + +makeGithub :: String -> IO String +makeGithub subject = do + z <- makeQuery ("select substr(Due,1,10) from todo where subject = '" ++ subject ++ "' and state = 0") + color <- getColor + let header = "

Calendar "++ subject ++ "

" + return (header ++ (Prelude.concat q )++ bot) + +colors :: [String] +colors = ["'#F44336'" + ,"'#E91E63'" + ,"'#9C27B0'" + ,"'#673AB7'" + ,"'#3F51B5'" + ,"'#2196F3'" + ,"'#03A9F4'" + ,"'#00BCD4'" + ,"'#009688'" + ,"'#4CAF50'" + ,"'#8BC34A'" + ,"'#CDDC39'" + ,"'#FFEB3B'" + ,"'#FFC107'" + ,"'#FF9800'" + ,"'#FF5722'" + ,"'#795548'" + ,"'#9E9E9E'" + ,"'#607D8B'" + ] + +getColor :: IO String +getColor = do + number <- randomRIO (0, (length $ colors)-1) :: IO Int + return (colors !! number) + diff --git a/src/Villefort/Summary.hs b/src/Villefort/Summary.hs new file mode 100644 --- /dev/null +++ b/src/Villefort/Summary.hs @@ -0,0 +1,15 @@ +module Villefort.Summary where +import Villefort.Database +import Control.Monad.IO.Class +import Villefort.Todo +import Villefort.Stats + +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 = do + dat <- liftIO $ getDone + header <- getHeader + return ( header ++ (makeTable ["Subject","Time"] dat)) +--2017-07-26 diff --git a/src/Villefort/Time.hs b/src/Villefort/Time.hs new file mode 100644 --- /dev/null +++ b/src/Villefort/Time.hs @@ -0,0 +1,36 @@ +module Villefort.Time where + +import Data.List.Split as S +import Data.Time +import Data.Time.Calendar.OrdinalDate + +data D = D { year :: Integer, + month :: Int, + day :: Int} deriving (Show) + +fromZonedTimeToDay :: String -> Day +fromZonedTimeToDay x = fromGregorian (year up) (month up ) (day up) + where up = unpackStringToDate x + +unpackStringToDate x = D (read (nums !! 0) :: Integer) (read (nums !! 1) :: Int) (read (nums !! 2) :: Int) + where nums = S.splitOn "-" $ take 10 x + + + +daysUntil date = do + c <- getCurrentTime + let (y,m,d) = toGregorian $ utctDay c + let split = S.splitOn "-" date + current <- fromZonedTimeToDay <$> show <$> getZonedTime + let due = fromGregorian (read (split !! 0) :: Integer) (read (split !! 1) :: Int) (read (split !! 2) :: Int) + return $ (diffDays due current) + +getDate :: IO Day +getDate = fromZonedTimeToDay <$> show <$> getZonedTime + +getDateD = unpackStringToDate <$> show <$> getZonedTime + +getDay :: IO Int +getDay = do + z <- getDate + return $ snd $mondayStartWeek z diff --git a/src/Villefort/Todo.hs b/src/Villefort/Todo.hs new file mode 100644 --- /dev/null +++ b/src/Villefort/Todo.hs @@ -0,0 +1,148 @@ +module Villefort.Todo where + +import Villefort.Database +import Villefort.Time +import Control.Monad.IO.Class +import Data.List.Split +import Paths_Villefort +import Database.HDBC + + +data Row = Row { rid :: Int, + title :: String, + description :: String, + due :: String, + subject :: String, + time :: Int, + pred :: Double + } deriving (Show) + +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' = 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) + +convRow' :: [[SqlValue]] -> [[String]] +convRow' dat = Prelude.map (\x -> Prelude.map (\y -> conv' y ) x) dat + +--conv h:: SqlValue -> String +conv' :: SqlValue -> String +conv' x = case fromSql x of + Just y -> fromSql y :: String + Nothing -> "0" + +--makeQuery :: Query -> IO [[String]] +makeQuery' :: String -> IO [[String]] +makeQuery' query = do + conn <- getDb + taskRaw <- quickQuery' conn query [] + disconnect conn + return (convRow' taskRaw) + + +merge :: [a] -> [a] -> [a] +merge [] ys = ys +merge (x:xs) ys = x:merge ys xs + + +genModal' :: Row -> IO String +genModal' row = if rid row == 1 then return (" ") else do + let f = due row + modal <- getModal + days <- daysUntil f + let da = [daysToColor' days , + show $ rid row, + (convTitle $ title row) ++ "Due in " ++ show days, + show $ rid row, + title row, + description row, + show $ time row, + show $ Villefort.Todo.pred row, + "/delete", + show $ rid row + ] + + return $ mconcat $ merge modal da + + +--genModal row = + +daysToColor' :: (Num a, Ord a) => a -> String +daysToColor' x = if x < 1 then "btn-due0" + else if x == 1 then "btn-due1" + else if x == 2 then "btn-due2" + else if x == 3 then "btn-due3" + else if x == 4 then "btn-due4" + else if x == 5 then "btn-due5" + else if x == 6 then "btn-due6" + else "btn-due7" + + + +convTitle :: String -> String +convTitle longTitle + | length s1 > 30 = s1 + | length s2 > 30 = s2 + | length s3 > 30 = s3 + | length s4 > 30 = s4 + | otherwise = longTitle + where splits = (Data.List.Split.splitOn "." longTitle) + s1 = (splits !! 0) + s2 = mconcat (take 2 splits) + s3 = mconcat (take 3 splits) + s4 = mconcat (take 4 splits) + + +getModal :: IO [[Char]] +--getModal = path >>= \path -> readFile (path ++ "templates/modal.ts") >>= \rawModal -> return (Data.List.Split.splitOn "}" rawModal) +getModal = getDataFileName "templates/modal.ts" >>= \path -> readFile path>>= \rawModal -> return (Data.List.Split.splitOn "}" rawModal) + + + +-- | Returns html from todos +getTodos :: IO String +getTodos = do + tasks <- qetTasks' + --do liftIO $ putStrLn $ show tasks + modals <- sequence $ genModal' <$> tasks + header <- getHeader + let body = Prelude.concat modals + return (header ++ body) + +getHeader :: IO String +getHeader = do + headerPath <-getDataFileName "templates/header" + header <- liftIO $ readFile headerPath + return header + +-- | 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 raw = do + let da = Data.List.Split.splitOn "&" (show raw) + let rawid = Data.List.Split.splitOn "=" $ (Prelude.init (da !! 1)) + let sqlId = read (rawid!! 1) :: Int + 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 + 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/templates/header b/templates/header --- a/templates/header +++ b/templates/header @@ -95,6 +95,7 @@
  • Home
  • New
  • Log
    • +
  • Today
    • diff --git a/templates/modal.ts b/templates/modal.ts --- a/templates/modal.ts +++ b/templates/modal.ts @@ -15,6 +15,7 @@

    }

    Total minutes spent working on Project }

    +

    Predicted time }

    diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,24 @@ +import Test.QuickCheck +import Test.QuickCheck.Monadic +--import Test.QuickCheck.Batch + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = quickCheck prop_commutativeAdd + +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]) + +prop_dat w x y z = monadicIO $ do + date <- run (dat w x y z) + assert date +-}