{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module System.Hapistrano.Config
( Config (..)
, CopyThing (..)
, Target (..))
where
import Control.Applicative ((<|>))
import Data.Aeson
import Data.Function (on)
import Data.List (nubBy)
import Data.Maybe (maybeToList)
import Data.Yaml
import Numeric.Natural
import Path
import System.Hapistrano.Commands
import System.Hapistrano.Types (Shell(..),
ReleaseFormat (..),
Source(..),
TargetSystem (..))
data Config = Config
{ configDeployPath :: !(Path Abs Dir)
, configHosts :: ![Target]
, configSource :: !Source
, configRestartCommand :: !(Maybe GenericCommand)
, configBuildScript :: !(Maybe [GenericCommand])
, configCopyFiles :: ![CopyThing]
, configCopyDirs :: ![CopyThing]
, configLinkedFiles :: ![FilePath]
, configLinkedDirs :: ![FilePath]
, configVcAction :: !Bool
, configRunLocally :: !(Maybe [GenericCommand])
, configTargetSystem :: !TargetSystem
, configReleaseFormat :: !(Maybe ReleaseFormat)
, configKeepReleases :: !(Maybe Natural)
} deriving (Eq, Ord, Show)
data CopyThing = CopyThing FilePath FilePath
deriving (Eq, Ord, Show)
data Target =
Target
{ targetHost :: String
, targetPort :: Word
, targetShell :: Shell
, targetSshArgs :: [String]
} deriving (Eq, Ord, Show)
instance FromJSON Config where
parseJSON = withObject "Hapistrano configuration" $ \o -> do
configDeployPath <- o .: "deploy_path"
let grabPort m = m .:? "port" .!= 22
grabShell m = m .:? "shell" .!= Bash
grabSshArgs m = m .:? "ssh_args" .!= []
host <- o .:? "host"
port <- grabPort o
shell <- grabShell o
sshArgs <- grabSshArgs o
hs <- (o .:? "targets" .!= []) >>= mapM (\m ->
Target
<$> m .: "host"
<*> grabPort m
<*> grabShell m
<*> grabSshArgs m)
let first Target{..} = host
configHosts = nubBy ((==) `on` first)
(maybeToList (Target <$> host <*> pure port <*> pure shell <*> pure sshArgs) ++ hs)
source m =
GitRepository <$> m .: "repo" <*> m .: "revision"
<|> LocalDirectory <$> m .: "local_directory"
configSource <- source o
configRestartCommand <- (o .:? "restart_command") >>=
maybe (return Nothing) (fmap Just . mkCmd)
configBuildScript <- o .:? "build_script" >>=
maybe (return Nothing) (fmap Just . mapM mkCmd)
configCopyFiles <- o .:? "copy_files" .!= []
configCopyDirs <- o .:? "copy_dirs" .!= []
configLinkedFiles <- o .:? "linked_files" .!= []
configLinkedDirs <- o .:? "linked_dirs" .!= []
configVcAction <- o .:? "vc_action" .!= True
configRunLocally <- o .:? "run_locally" >>=
maybe (return Nothing) (fmap Just . mapM mkCmd)
configTargetSystem <- o .:? "linux" .!= GNULinux
configReleaseFormat <- o .:? "release_format"
configKeepReleases <- o .:? "keep_releases"
return Config {..}
instance FromJSON CopyThing where
parseJSON = withObject "src and dest of a thing to copy" $ \o ->
CopyThing <$> (o .: "src") <*> (o .: "dest")
instance FromJSON TargetSystem where
parseJSON = withBool "linux" $
pure . \case
True -> GNULinux
False -> BSD
mkCmd :: String -> Parser GenericCommand
mkCmd raw =
case mkGenericCommand raw of
Nothing -> fail "invalid restart command"
Just cmd -> return cmd