{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}


module System.Nemesis.Titan where
  
import System.Nemesis.Env
import System.Nemesis (Unit)

import Air.Env
import Prelude ()
import Air.TH (here, mkDefault)

import qualified Data.ByteString.Char8 as B
import qualified Data.UUID as UUID
import System.Directory
import System.Random
import System.FilePath
import System.Exit (ExitCode(..))
import qualified Control.Exception as E
import Control.Monad (forever)

import Test.Hspec
import Text.StringTemplate
import Text.Printf

angel_template :: StringTemplate String
angel_template = newSTMP - [here|
server {
    exec = "runghc Nemesis $label$/run"
    stdout = "/dev/stdout"
    stderr = "/dev/stderr"
    delay = 0
}

code-reload {
    exec = "runghc Nemesis $label$/guard"
    stdout = "/dev/stdout"
    stderr = "/dev/stderr"
    delay = 0
}
|]

-- Live mode without auto recompile, e.g. `runghc Nemesis compile-and-kill` is run inside git-post-receive-hook
angel_live_template :: StringTemplate String
angel_live_template = newSTMP - [here|
server {
    exec = "runghc Nemesis $label$/run"
    stdout = "/dev/stdout"
    stderr = "/dev/stderr"
    delay = 0
}
|]

guard_template :: StringTemplate String
guard_template = newSTMP - [here|
guard :shell do
  event_time = Time.now
  update_time = Time.now
  update_interval = 0.1
  
  watch(%r{^src/.+hs\$}) do |m|
    puts "Changed #{m[0]}"
    event_time = Time.now
  end

  # compile at most once for every \$update_interval seconds
  Thread.new do 
    while true
      sleep update_interval
      if event_time > update_time 
        update_time = Time.now
        system("runghc Nemesis $label$/compile-and-kill")
      end
    end
  end
  
end
|]


haskell_template :: StringTemplate String
haskell_template = newSTMP - [here|
module Main where

import System.Nemesis.Titan
import Test.Hspec

spec :: IO ()
spec = hspec \$ do
  describe "$label$" \$ do
    it "should run spec" True

main = do
  with_spec spec halt

|]

titan_spec :: IO ()
titan_spec = hspec - do
  describe "Titan" - do
    it "should run spec" True
    
    it "should use templates" - do
      let text = render - setAttribute "label" "Main" angel_template
      
      -- puts text
      
      text `shouldSatisfy` (null > not)
      


data Config = Config
  {
    pid_name :: String
  , bin_directory :: String
  , config_directory :: String
  , haskell_source_directory :: String
  , label :: String
  , file_name :: String
  , ghc_arg_string :: String
  , ghc_default_arg_string :: String
  , guard_arg_string :: String
  , guard_default_arg_string :: String
  }
  deriving (Show, Eq)

mkDefault ''Config


defaultConfig :: Config
defaultConfig = def
    {
      pid_name = "uuid.txt"
    , bin_directory = ".bin"
    , config_directory = "config"
    , haskell_source_directory = "src"
    , ghc_default_arg_string = "-threaded"
    , guard_default_arg_string = "--no-bundler-warning --no-interactions"
    }

titan_with_config :: Config -> Unit
titan_with_config config = do
  namespace (config.label) - do
    
    let  
      _label = config.label
      config_label_directory = config.config_directory / _label
      angel_path = config_label_directory / "Angel.conf"
      angel_live_path = config_label_directory / "AngelLive.conf"
      guard_path = config_label_directory / "Guardfile"
      
      pid_directory = config.bin_directory / _label
      pid_path = pid_directory / config.pid_name

      haskell_source_path = config.haskell_source_directory / config.file_name
      
    desc "Initialize a Titan node"
    task "init" - io - do
      createDirectoryIfMissing True config_label_directory
      createDirectoryIfMissing True (config.haskell_source_directory)
      
      let 
        angel_file_content = render - setAttribute "label" _label angel_template
        angel_live_file_content = render - setAttribute "label" _label angel_live_template
        guard_file_content = render - setAttribute "label" _label guard_template
        haskell_file_content = render - setAttribute "label" _label haskell_template
      
      let {
        write_if_not_exist file_path str = do
          file_exist <- doesFileExist file_path
          if not - file_exist
            then
              B.writeFile file_path - B.pack str
            else do
              puts - file_path + " already exists!"
              return ()
      }
      
      write_if_not_exist angel_path angel_file_content 
      write_if_not_exist angel_live_path angel_live_file_content 
      write_if_not_exist guard_path guard_file_content 
      write_if_not_exist haskell_source_path haskell_file_content
    
                      
    let { get_and_create_if_missing_upid = do
      createDirectoryIfMissing True pid_directory

      pid_exist <- doesFileExist pid_path


      if pid_exist
        then do
          uuid <- B.readFile pid_path ^ B.unpack
          return uuid      
        else do
          uuid <- randomIO ^ UUID.toString
          puts - "Created UPID: " + uuid
          B.writeFile pid_path - uuid.B.pack
          return - uuid
      }
          
    let { get_bin = do
      uuid <- get_and_create_if_missing_upid
      return - pid_directory / uuid
    }

    desc "Start the Titan managed process"
    task "titan:uuid compile" - do
      sh - "angel " + angel_path
    
    desc "Start the Titan managed process for deployment (no auto recompile)"
    task "titan-live:uuid compile" - do
      sh - "angel " + angel_live_path
  
    desc "Create a uuid for this process if not already exist"
    task "uuid" - do
      io - void - get_and_create_if_missing_upid

    desc "Compile the binary"
    task "compile" - do
      bin <- get_bin
      let { cmd =
        printf "ghc --make -i%s %s %s %s -o %s" 
          (config.haskell_source_directory)
          (config.ghc_default_arg_string)
          (config.ghc_arg_string)
          haskell_source_path
          bin
        }
      
      -- puts cmd
      sh cmd

    desc "Start the process"
    task "run" - do
      bin <- get_bin
      sh - bin

    desc "Kill the process"
    task "kill" - do
      upid <- get_and_create_if_missing_upid
      sh - "killall -SIGTERM " + upid + "; true"
  
    desc "Compile and Kill"
    task "compile-and-kill: compile kill" - return ()
    
    desc "Start the Guard process"
    task "guard" - do
      sh - printf "guard %s %s -G %s" 
        (config.guard_default_arg_string)
        (config.guard_arg_string)
        guard_path
  


titan :: String -> Unit
titan _file_name = do
  let _label = _file_name.takeBaseName
  titan_with_config defaultConfig {file_name = _file_name, label = _label}




-- Helpers
safe_spec :: IO () -> IO ExitCode
safe_spec spec = E.handle (\e -> return (e :: ExitCode)) - do
  spec
  return ExitSuccess

halt :: IO ()
halt = forever - sleep (1 :: Double)
  
with_spec :: IO () -> IO b -> IO ()
with_spec spec process = do
  exit_code <- safe_spec spec
  
  case exit_code of
    ExitSuccess -> do
      fork - process
    _ ->
      return ()
  
  halt