module System.Nemesis.Titan where
import System.Nemesis.Env
import System.Nemesis (Unit)
import Air.Env
import Prelude ()
import Air.TH (here)
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
angel_template :: StringTemplate String
angel_template = newSTMP [here|
server {
exec = "runghc Nemesis $label$/run"
stdout = "/dev/stdout"
stderr = "/dev/stderr"
delay = 0
}
codereload {
exec = "runghc Nemesis $label$/guard"
stdout = "/dev/stdout"
stderr = "/dev/stderr"
delay = 0
}
|]
guard_template :: StringTemplate String
guard_template = newSTMP [here|
guard :shell do
watch(%r{^src/.+hs\$}) do |m|
puts "Changed #{m[0]}"
`runghc Nemesis $label$/compile && runghc Nemesis $label$/kill`
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
text `shouldSatisfy` (null > not)
titan :: String -> Unit
titan file_name = do
let label = file_name.takeBaseName
titan_with_label_file_name label file_name
titan_with_label_file_name :: String -> String -> Unit
titan_with_label_file_name label file_name = titan_with_label_file_name_custom_task label file_name (return ())
titan_with_label_file_name_custom_task :: String -> String -> Unit -> Unit
titan_with_label_file_name_custom_task label file_name custom_tasks = do
namespace label do
let
pid_name = "uuid.txt"
bin_directory = ".bin"
config_name = "config"
config_directory = config_name / label
angel_path = config_directory / "Angel.conf"
guard_path = config_directory / "Guardfile"
pid_directory = bin_directory / label
pid_path = pid_directory / pid_name
desc "Initialize a Titan node"
task "init" io do
let
haskell_source_directory = "src"
haskell_path = haskell_source_directory / file_name
createDirectoryIfMissing True config_directory
createDirectoryIfMissing True haskell_source_directory
let
angel_file_content = render setAttribute "label" label angel_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 guard_path guard_file_content
write_if_not_exist haskell_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
puts "UPID: " + uuid
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 "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
sh "ghc --make -isrc -threaded src/" + file_name + " -o " + bin
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 " + upid + "; true"
desc "Start the Guard proceses"
task "guard" do
sh "guard --no-bundler-warning -G " + guard_path
custom_tasks
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