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