{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Villefort.Server where import Web.Scotty import Control.Monad.Reader import Control.Concurrent import Data.Text.Lazy hiding (splitOn,map,concat,head,replace) import Villefort.Database import Villefort.Todo (deleteTodo,getTodos,updateTodos) import Villefort.Log import Villefort.Definitions import Villefort.Weekly import Paths_Villefort import Villefort.Daily import Villefort.New (makeNewPage) import Villefort.Today import Data.List.Split import System.Environment import System.Process import System.Directory import System.Posix.Process import Data.String.Utils 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) -- | Entry point for server attempts to recompile if needed villefort :: VConfig -> IO () villefort conf = do args <- getArgs case args of ["--custom",_] -> putStrLn "custom" >> launch conf ["--recompile"] -> putStrLn "recompiling" >> recompile _ -> do if noCustom conf then launch conf >> putStrLn "overload" else checkCustomBuild >> launch conf -- | recompiles villefort by calling ghc expects .villefort/villefort.hs in home directory 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 () -- | checks for executable in villefort home folder if so it executes it checkCustomBuild :: IO () checkCustomBuild = do dir <- getAppUserDataDirectory "villefort" let path = dir ++ "/villefort" putStrLn path isBuild <- doesFileExist path dataDir <- getDataDir if isBuild then putStrLn "custom build detected" >> executeFile path True ["--custom",dataDir] Nothing else putStrLn "no custom build found" -- | actually launches the scotty server 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) 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 liftIO $ runReaderT (updateTodos sqlId insertTime) conf redirect "/" post "/add" $ do rawBody <-body let parse = Data.List.Split.splitOn "&" (show rawBody) do liftIO $ print parse -- !@#$%^&*()_+ 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