{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Villefort.Server 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)
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 buil detected" >> executeFile path True ["--custom",dataDir] Nothing
else putStrLn "no custom build :("
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 rep = replace "+" " " . replace "%21" "!" . replace "%40" "@" . replace "%23" "#" . replace "%24" "$" . replace "%25" "%" . replace "%5E" "^" . replace "%26" "&" . replace "%28" "(" . replace "%29" ")" . replace "%2B" "+"
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 "/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