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 Villefort.Definitions
import Paths_Villefort
import Villefort.Ml
import Villefort.Time
import Villefort.Summary
import Villefort.Daily
import System.IO.Strict as S
import System.Environment
import Control.Monad
import Control.Monad.Reader
import System.Process
import System.Directory
import System.Posix.Process
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
getIndex :: [[Char]] -> Int -> [Char]
getIndex str i = (Data.List.Split.splitOn "=" (str !! i)) !! 1
convDate :: String -> String
convDate date = newDate
where splitDate = Data.List.Split.splitOn "%2F" date
newDate = (splitDate !! 2) ++ "-" ++ (splitDate !! 0) ++ "-" ++ (splitDate !! 1)
makeRadio :: String -> String
makeRadio x = "<dd><input type='radio' name='subject' value='"++ x ++ "'> " ++ x ++ "</br> \n"
makeNewPage :: (MonadReader VConfig m, MonadIO m) => m String
makeNewPage = do
headerPath <-liftIO $ getDataFileName "templates/header"
htmlHeader <- liftIO $ S.readFile headerPath
addPath <- liftIO $ 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))
writeDate :: IO ()
writeDate = do
date <- show <$> getDate
datePath <- getDataFileName "data/date"
writeFile datePath date
readDate :: IO D
readDate = do
datePath <- getDataFileName "data/date"
rawDate <- S.readFile datePath
let date = unpackStringToDate rawDate
return date
writeDay :: IO ()
writeDay = do
newDay <- show <$> getDay
datePath <- getDataFileName "data/day"
writeFile datePath newDay
readDay :: IO Int
readDay = do
datePath <- getDataFileName "data/day"
rawDay <- S.readFile datePath
let int = read rawDay :: 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 :: VConfig -> D -> D -> IO ()
runDaily vconf oldDate currentDate=
if (checkDay oldDate currentDate) then
putStrLn "same-day"
else
putStrLn "adding-daily" >> do
dailies <- sequence (daily vconf)
mapM_ add dailies
where add = (\x -> if Prelude.null x then return () else runReaderT ( addDaily x) 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"
runWeekly :: VConfig -> Int -> Int -> IO ()
runWeekly conf old current = do
if old /= current
then do
let stmt = selector conf (current1)
stmts <- sequence stmt
mapM_ add stmts
else return ()
where add = (\x -> if Prelude.null x then return () else runReaderT ( addDaily x) conf)
selector :: (Num a, Eq a) => VConfig -> a -> [IO [String]]
selector conf x
| x == 0 = monday lookconf
| x == 1 = tuesday lookconf
| x == 2 = wednesday lookconf
| x == 3 = thursday lookconf
| x == 4 = friday lookconf
| x == 5 = saturday lookconf
| otherwise = sunday lookconf
where lookconf = weekly conf
man :: VConfig -> 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 :: VConfig -> IO b
dailyCheck conf = forever$ man conf
villefort :: VConfig -> IO ()
villefort conf = do
args <- getArgs
case args of
["--custom",_] -> putStrLn "custom" >> launch conf
["--recompile"] -> putStrLn "recompiling" >> recompile
_ -> putStrLn "straight starting " >> do
if noCustom conf
then launch conf >> putStrLn "overload"
else 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 :: IO ()
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 $ runReaderT getTodos conf
html $ pack $ todos
get "/new" $ do
page <- liftIO $ runReaderT makeNewPage conf
html $ pack page
post "/delete" $ do
rawHtml <- body
runReaderT (deleteTodo rawHtml) conf
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 $ runReaderT (updateTask sqlId insertTime) conf
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 $ runReaderT (addTask todoTitle summary date todoSubject) conf
redirect "/"
get "/time" $ do
dat <-liftIO $ runReaderT getSummary conf
html $ pack dat
get "/js-chart-widgets.min.js" $ do
jsPath <- liftIO $ getDataFileName "js.js"
file jsPath
get "/weekly" $ do
to <- liftIO $ runReaderT weeklyStats conf
html $ pack to
get "/stat" $ do
page <- liftIO $runReaderT genStats conf
html $ pack page