diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Chris Reuter (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Chris Reuter nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# Villefort +Villefort is a time managment system written in Haskell and backed by sqlite. +#Home screen +![alt text](https://raw.githubusercontent.com/Chrisr850/Villefort/master/data/screen.png) +# Villefort has page to add new todos +![alt text](https://raw.githubusercontent.com/Chrisr850/Villefort/master/data/screen01.png) +# Villefort also a stats page which shows how much time you spend on each subject as well as github like time tracker + +![alt text](https://raw.githubusercontent.com/Chrisr850/Villefort/master/data/screen02.png) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Villefort.cabal b/Villefort.cabal new file mode 100644 --- /dev/null +++ b/Villefort.cabal @@ -0,0 +1,56 @@ +name: Villefort +version: 0.1.0.0 +synopsis: Villefort is a task manager and time tracker written in haskell. +description: It is based off of a sqlite database and has the ability to add new tasks +homepage: https://github.com/Chrisr850/Villefort#readme +license: BSD3 +license-file: LICENSE +author: Chris Reuter +maintainer: creuter@lsoc.org +copyright: 2017 Chris Reuter +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Lib + , Database + , Todo + , Stats + build-depends: base >= 4.7 && < 5 + , HDBC + , HDBC-sqlite3 + , split + , time + , FindBin + , mtl + default-language: Haskell2010 + +executable Villefort + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , Villefort + , scotty + , HDBC-sqlite3 + , HDBC + , split + , text + , time + default-language: Haskell2010 + +test-suite Villefort-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , Villefort + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/Chrisr850/Villefort diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,106 @@ +{-# 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) +import Data.Time +import Database +import Todo +import Stats + + + + +getDone = makeQuery "select Title, time from todo where due = Date('now','+1 day') 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 + + +convDate :: String -> String +convDate date = newDate + where split = Data.List.Split.splitOn "%2F" date + newDate = (split !! 2) ++ "-" ++ (split !! 0) ++ "-" ++ (split !! 1) + + + +makeRadio x = "
" ++ x ++ "
\n" + + +makeNewPage = do + path <- path + rawhtml <- liftIO $ readFile (path ++ "templates/add.html") + let split = splitOn "?" rawhtml + subjects <- getSubjects + let radiobuttons = map makeRadio subjects + return ((split !! 0) ++ (concat radiobuttons) ++ (split !! 1)) + + +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 + stmt <- liftIO $ prepare conn "insert into todo (Description,Title,Entered,Due,State,time,Subject) Values (?,?,current_date,?,1,0,?)" + do liftIO $ execute stmt [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 $ path + file (path ++ "js.js") + + get "/stat" $ do + page <- liftIO $ genStats + html $ pack page diff --git a/src/Database.hs b/src/Database.hs new file mode 100644 --- /dev/null +++ b/src/Database.hs @@ -0,0 +1,36 @@ +{-# 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 + +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 =fmap (\x -> (x !! 0) ++ "Villefort/") $ (Data.List.Split.splitOn "Villefort/") <$> getProgPath + +getDb :: IO Connection +getDb = (++ "data/todo.db") <$> path >>= \path -> putStrLn path >> connectSqlite3 path + +conv :: [[SqlValue]] -> [[String]] +conv dat = Prelude.map (\x -> Prelude.map (\y -> fromSql y :: String) x) dat + +makeQuery :: Query -> IO [[String]] +makeQuery query = getDb >>= \conn -> quickQuery' conn query [] >>= + \taskRaw -> disconnect conn >> return ( conv 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/Lib.hs b/src/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/src/Stats.hs b/src/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Stats.hs @@ -0,0 +1,28 @@ +module Stats where +import Database +import Control.Monad.IO.Class + +data Query = Query String + +getAvg = makeQuery "select avg(time), Subject from todo group by Subject order by avg(time) desc" + +getSum = makeQuery "select sum(time), Subject from todo group by Subject order by sum(time) desc" + +makeRow x = " " ++ (x !! 0) ++ " " ++ (x!! 1) ++ " " + +makeTable stats = "" ++ (mconcat (map makeRow stats)) ++ "
" + + +genStats = getSubjects >>= mapM makeGithub >>= \gits -> getAvg >>= + \avg -> getSum >>= \sum -> return (hea ++ (makeTable avg) ++ "

Sum

" ++ (makeTable sum) ++ "" ++ (mconcat gits)) + +hea :: String +hea = "

avg

" + +makeGithub :: String -> IO String +makeGithub subject = do + z <- makeQuery ("select Due from todo where subject = '" ++ subject ++ "' and state = 0") + let head = "

Calendar "++ subject ++ "

" + return (head ++ (Prelude.concat q )++ bot) diff --git a/src/Todo.hs b/src/Todo.hs new file mode 100644 --- /dev/null +++ b/src/Todo.hs @@ -0,0 +1,113 @@ +module Todo where + +import Database +import Data.List.Split +import Control.Monad.IO.Class +import Data.Time + +data Row = Row { rid :: Int, + title :: String, + description :: String, + due :: String, + time :: Int + } deriving (Show) + +toRow :: [String] -> Row +toRow x = Row (read (x !! 0) :: Int) (x !! 1) (x !! 2) (x !! 3) (read( x !! 4) :: Int) + +qetTasks' = makeQuery "select id, Title, Description, Due, time from todo where state = 1 order by Due" >>= + \x -> return (map toRow x) + + + + + +merge [] ys = ys +merge (x:xs) ys = x:merge ys xs + + + +genModal' row = 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, + "/delete", + show $ time row, + 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) + +daysTilDue date = do + c <- getCurrentTime + let (y,m,d) = toGregorian $ utctDay c + let split = Data.List.Split.splitOn "-" date + let current = fromGregorian y m d + let due = fromGregorian (read (split !! 0) :: Integer) (read (split !! 1) :: Int) (read (split !! 2) :: Int) + return $ (diffDays due current) -1 + + +getTodos = do + tasks <- qetTasks' + path <- path + modals <- sequence $ Prelude.map genModal' tasks + header <- readFile (path ++ "templates/index.html") + let body = Prelude.concat modals + return (header ++ body) + +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 "update todo set time = time + ? where id = ?" [ time, id] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"