Server.hs

{-# 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 
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
  let path = database conf
  makeTable path
  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