ServerType.hs

module Test.Hspec.Server.ServerType where

import System.Process
import System.Exit
import System.IO.Temp
import System.IO
import Data.Monoid
import Data.Maybe
import Control.Monad
import Test.Hspec.Server.Type

data Localhost = Localhost deriving (Show,Eq)

localhost :: Localhost
localhost = Localhost

instance ServerType Localhost where
  setup a = return a
  name _ = "localhost"
  cmd _ = readProcessWithExitCode

data Ssh = Ssh {
  sshHostName :: String
, sshId :: Maybe String
, sshConf :: Maybe String
, sshPort :: Maybe Int
, sshUser :: Maybe String
} deriving (Show,Eq)

ssh :: String -> Ssh
ssh hostname = Ssh hostname Nothing Nothing Nothing Nothing

instance ServerType Ssh where
  setup a = return a
  name = sshHostName
  cmd d c arg i = do
    readProcessWithExitCode "ssh" (sshOpt ++ [sshHost] ++ [c] ++ arg) i
    where
      sshOpt =
        (maybe [] (\v-> ["-p",show v]) (sshPort d)) ++
        (maybe [] (\v-> ["-i",show v]) (sshId d)) ++
        (maybe [] (\v-> ["-F",show v]) (sshConf d))
      sshHost = (maybe "" (\v -> v <> "@") (sshUser d)) <> sshHostName d

data Vagrant = Vagrant {
   vHostName :: String
 , vConf :: Maybe String
} deriving (Show,Eq)

vagrant :: String -> Vagrant
vagrant hostname = Vagrant hostname Nothing

instance ServerType Vagrant where
  setup a = do
    (e,conf,_) <- readProcessWithExitCode "vagrant" ["ssh-config"] []
    when (e /= ExitSuccess) $ do
      error "vagrant setup error"
    return $ a {vConf = Just conf}
  name = vHostName
  cmd d c arg i = withSystemTempFile "hspec-server" $ \file handle -> do
    hPutStr handle (fromJust (vConf d))
    hClose handle
    readProcessWithExitCode "ssh" (["-F",file,name d,c]++arg) i