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


module System.Nemesis.Titan where

import System.Nemesis.Env
import System.Nemesis (Unit)

import Air.Env hiding (mod)
import Prelude ()
import Air.TH
import Air.Data.Record.SimpleLabel (get, set, mod, label)

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

import Data.Maybe (fromMaybe)

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

code-reload {
    exec = "runghc Nemesis $project_name$/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 $project_name$/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 $project_name$/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 "$project_name$" \$ 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 "project_name" "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
  , project_name :: 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)

mkLabel ''Config

instance Default Config where
  def = Config
    {
      pid_name = "uuid.txt"
    , bin_directory = ".bin"
    , config_directory = "config"
    , haskell_source_directory = "src"
    , project_name = "Main"
    , file_name = "Main.hs"
    , ghc_arg_string = def
    , ghc_default_arg_string = "-threaded"
    , guard_arg_string = def
    , guard_default_arg_string = "--no-bundler-warning --no-interactions"
    }


titan_with_config :: Config -> Unit
titan_with_config config = do
  namespace (config.project_name) - do

    let
      _project_name = config.project_name
      config_project_name_directory = config.config_directory / _project_name
      angel_path = config_project_name_directory / "Angel.conf"
      angel_live_path = config_project_name_directory / "AngelLive.conf"
      guard_path = config_project_name_directory / "Guardfile"

      pid_directory = config.bin_directory / _project_name
      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_project_name_directory
      createDirectoryIfMissing True (config.haskell_source_directory)

      let
        angel_file_content = render - setAttribute "project_name" _project_name angel_template
        angel_live_file_content = render - setAttribute "project_name" _project_name angel_live_template
        guard_file_content = render - setAttribute "project_name" _project_name guard_template
        haskell_file_content = render - setAttribute "project_name" _project_name 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


  -- shortcut
  let shortcut_task_name = printf "t:%s/titan" (config.project_name)
      shortcut_description = printf "Short task name for %s/titan" (config.project_name)

  desc shortcut_description
  task shortcut_task_name - return ()


titan :: String -> Unit
titan _file_name = do
  let _project_name = _file_name.takeBaseName
  titan_with_config def {file_name = _file_name, project_name = _project_name}


data MacAppArgs = MacAppArgs
  {
    derived_data_path :: String
  , scheme_name :: Maybe String
  , target_name :: String
  , frameworks :: [String]
  , mac_app_config :: Config
  , mac_app_project_name :: Maybe String
  , mac_app_file_name :: Maybe String
  }
  deriving (Show)

mkLabel ''MacAppArgs

default_mac_app_config :: Config
default_mac_app_config =
  def.set __ghc_arg_string "-lobjc"

instance Default MacAppArgs where
  def = MacAppArgs
    {
      derived_data_path = "DerivedData"
    , scheme_name = def
    , target_name = "Hello World Application"
    , frameworks = ["Cocoa"]
    , mac_app_config = default_mac_app_config
    , mac_app_project_name = def
    , mac_app_file_name = def
    }

titan_mac_app :: MacAppArgs -> Unit
titan_mac_app args = do
  let
      _target_name = args.target_name
      _dashed_target_name = _target_name.map (\x -> if x.is ' ' then '-' else x)
      _project_name = args.mac_app_project_name.fromMaybe _dashed_target_name
      _file_name = args.mac_app_file_name.fromMaybe (args.mac_app_config.file_name)

      _new_ghc_arg_string = args.frameworks.map ("-framework" +) .join " "

      _config =
        args.mac_app_config
          .set __file_name _file_name
          .set __project_name _project_name
          .mod __ghc_arg_string (_new_ghc_arg_string + " " +)

  titan_with_config _config

  let
      _scheme_name = args.scheme_name.fromMaybe _target_name
      _derived_data_path = args.derived_data_path



  namespace _project_name - do

    let config = _config
        haskell_source_path = config.haskell_source_directory / config.file_name
        bin = config.bin_directory / _project_name / "dummy_binary"

    task ("clean") - do
      sh - printf "rm -rf %s" _derived_data_path
      sh - printf "mkdir %s" _derived_data_path
      sh - printf "rm %s" bin

    desc "Compile the binary"
    task ("compile:uuid") - do
      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
        }

      sh cmd

      let xcode_build_cmd = printf "cd .. && xcodebuild -scheme '%s' > /dev/null" _scheme_name
      sh xcode_build_cmd

    task ("kill") - do
      let osascript = printf "tell application \"%s\" to quit" _target_name
      sh - printf "osascript -e '%s'" (osascript :: String)

    task ("run") - do
      sh - printf "cd %s; find . -name '%s' -exec '{}' \\;" _derived_data_path _target_name


  -- shortcut
  let shortcut_task_name = printf "t:%s/kill %s/titan" _project_name _project_name
      shortcut_description = printf "%s/kill then %s/titan" _project_name _project_name

  desc shortcut_description
  task shortcut_task_name - return ()

-- 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