{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module System.Hapistrano.Types
( Hapistrano
, Failure(..)
, Config(..)
, Source(..)
, Task(..)
, ReleaseFormat(..)
, SshOptions(..)
, OutputDest(..)
, Release
, TargetSystem(..)
, Shell(..)
, mkRelease
, releaseTime
, renderRelease
, parseRelease
, fromMaybeReleaseFormat
, fromMaybeKeepReleases
, toMaybePath
) where
import Control.Applicative
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson
import Data.Maybe
import Data.Time
import Numeric.Natural
import Path
type Hapistrano a = ExceptT Failure (ReaderT Config IO) a
data Failure =
Failure Int (Maybe String)
data Config =
Config
{ configSshOptions :: !(Maybe SshOptions)
, configShellOptions :: !Shell
, configPrint :: !(OutputDest -> String -> IO ())
}
data Source
= GitRepository
{ gitRepositoryURL :: String
, gitRepositoryRevision :: String
}
| LocalDirectory
{ localDirectoryPath :: Path Abs Dir
}
deriving (Eq, Ord, Show)
data Task =
Task
{ taskDeployPath :: Path Abs Dir
, taskSource :: Source
, taskReleaseFormat :: ReleaseFormat
}
deriving (Show, Eq, Ord)
data ReleaseFormat
= ReleaseShort
| ReleaseLong
deriving (Show, Read, Eq, Ord, Enum, Bounded)
instance FromJSON ReleaseFormat where
parseJSON =
withText "release format" $ \case
"short" -> return ReleaseShort
"long" -> return ReleaseLong
_ -> fail "expected 'short' or 'long'"
data Shell
= Bash
| Zsh
deriving (Show, Eq, Ord)
instance FromJSON Shell where
parseJSON =
withText "shell" $ \case
"bash" -> return Bash
"zsh" -> return Zsh
_ -> fail "supported shells: 'bash' or 'zsh'"
data SshOptions =
SshOptions
{ sshHost :: String
, sshPort :: Word
, sshArgs :: [String]
}
deriving (Show, Read, Eq, Ord)
data OutputDest
= StdoutDest
| StderrDest
deriving (Eq, Show, Read, Ord, Bounded, Enum)
data Release =
Release ReleaseFormat UTCTime
deriving (Eq, Show, Ord)
data TargetSystem
= GNULinux
| BSD
deriving (Eq, Show, Read, Ord, Bounded, Enum)
mkRelease :: ReleaseFormat -> UTCTime -> Release
mkRelease = Release
releaseTime :: Release -> UTCTime
releaseTime (Release _ time) = time
renderRelease :: Release -> String
renderRelease (Release rfmt time) = formatTime defaultTimeLocale fmt time
where
fmt =
case rfmt of
ReleaseShort -> releaseFormatShort
ReleaseLong -> releaseFormatLong
parseRelease :: String -> Maybe Release
parseRelease s =
(Release ReleaseLong <$> p releaseFormatLong s) <|>
(Release ReleaseShort <$> p releaseFormatShort s)
where
p = parseTimeM False defaultTimeLocale
releaseFormatShort, releaseFormatLong :: String
releaseFormatShort = "%Y%m%d%H%M%S"
releaseFormatLong = "%Y%m%d%H%M%S%q"
fromMaybeReleaseFormat ::
Maybe ReleaseFormat -> Maybe ReleaseFormat -> ReleaseFormat
fromMaybeReleaseFormat cliRF configRF =
fromMaybe ReleaseShort (cliRF <|> configRF)
fromMaybeKeepReleases :: Maybe Natural -> Maybe Natural -> Natural
fromMaybeKeepReleases cliKR configKR =
fromMaybe defaultKeepReleases (cliKR <|> configKR)
defaultKeepReleases :: Natural
defaultKeepReleases = 5
toMaybePath :: Source -> Maybe (Path Abs Dir)
toMaybePath (LocalDirectory path) = Just path
toMaybePath _ = Nothing