{-# 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) -- | parses value from raw html post form 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 _ -> putStrLn "straight starting " >> 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 "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" isBuild <- doesFileExist path dataDir <- getDataDir if isBuild then putStrLn "custom build detected" >> executeFile path True ["--custom",dataDir] Nothing else putStrLn "no custom build detected" -- | 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) 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