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
}
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)
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
}
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"
}
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"
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
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_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
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
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
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 process"
task "guard" do
sh "guard --no-bundler-warning -i -G " + guard_path
titan :: String -> Unit
titan _file_name = do
let _label = _file_name.takeBaseName
titan_with_config defaultConfig {file_name = _file_name, label = _label}
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