{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
module Villefort.Server (villefort) where
import Web.Scotty (scotty
,get
,html
,post
,body
,redirect
,html
,param
,file)
import Control.Monad.Reader (liftIO,runReaderT)
import Control.Concurrent (forkIO)
import Data.Text.Lazy (pack)
import Villefort.Database (addTask)
import Villefort.Todo (deleteTodo,getTodos,updateTodos)
import Villefort.Log (genStats)
import Villefort.Definitions (VConfig(..))
import Villefort.Weekly (weeklyStats)
import Paths_Villefort (getDataFileName,getDataDir)
import Villefort.Daily (dailyCheck)
import Villefort.New (makeNewPage)
import Villefort.Today (getSummary)
import Data.List.Split (splitOn)
import System.Environment (getArgs)
import System.Process (createProcess,proc,waitForProcess)
import System.Directory (getAppUserDataDirectory,doesFileExist)
import System.Posix.Process (executeFile)
import Data.String.Utils (replace)
import Network.URI.Encode (decode)
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)
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 "ghc" ["-o",execPath,sourcePath])
_ <- waitForProcess pid
return ()
checkCustomBuild :: IO ()
checkCustomBuild = do
dir <- getAppUserDataDirectory "villefort"
let path = dir ++ "/villefort"
isBuild <- doesFileExist path
dataDir <- getDataDir
if isBuild
then putStrLn "custom build detected" >> executeFile path True ["--custom",dataDir] Nothing
else putStrLn "no custom build detected"
launch :: VConfig -> IO ()
launch conf = do
_ <- forkIO $ dailyCheck conf
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)
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 insertTime = read (rawtime !! 1) :: Int
liftIO $ runReaderT (updateTodos sqlId insertTime) conf
redirect "/"
post "/add" $ do
rawBody <-body
let parse = Data.List.Split.splitOn "&" (show rawBody)
let clean = replace "+" " "
let summary = clean . decode $ getIndex parse 0
let date = convDate $ getIndex parse 3
let todoTitle = clean . decode $ getIndex parse 1
let todoSubject = clean . decode $ getIndex parse 2
liftIO $ runReaderT (addTask todoTitle summary date todoSubject) conf
redirect "/"
get "/today" $ do
dat <-liftIO $ runReaderT getSummary conf
html $ pack dat
get "/templates/:asset" $ do
asset <- param "asset"
path <- liftIO $ getDataFileName $ "templates/" ++ asset
file path
get "/weekly" $ do
to <- liftIO $ runReaderT weeklyStats conf
html $ pack to
get "/log" $ do
page <- liftIO $runReaderT genStats conf
html $ pack page