114 lines
3.9 KiB
Haskell
114 lines
3.9 KiB
Haskell
module MiniReleaseRequest.Request where
|
|
|
|
import Data.List (find, intercalate)
|
|
|
|
data Environment
|
|
= Staging
|
|
| Production
|
|
deriving (Eq, Show)
|
|
|
|
data Strategy
|
|
= Rolling
|
|
| Canary Int
|
|
deriving (Eq, Show)
|
|
|
|
data ReleaseRequest = ReleaseRequest
|
|
{ serviceName :: String
|
|
, environment :: Environment
|
|
, replicaCount :: Int
|
|
, strategy :: Strategy
|
|
, owner :: Maybe String
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
parseAssignment :: String -> Either String (String, String)
|
|
parseAssignment input =
|
|
case break (== '=') input of
|
|
([], _) -> Left ("expected key=value, got: " ++ input)
|
|
(_, "") -> Left ("expected key=value, got: " ++ input)
|
|
(key, '=' : value)
|
|
| null value -> Left ("missing value for key: " ++ key)
|
|
| otherwise -> Right (key, value)
|
|
_ -> Left ("expected key=value, got: " ++ input)
|
|
|
|
lookupOptional :: String -> [(String, String)] -> Maybe String
|
|
lookupOptional key assignments = snd <$> find ((== key) . fst) assignments
|
|
|
|
lookupRequired :: String -> [(String, String)] -> Either String String
|
|
lookupRequired key assignments =
|
|
case lookupOptional key assignments of
|
|
Just value -> Right value
|
|
Nothing -> Left ("missing required field: " ++ key)
|
|
|
|
parseEnvironment :: String -> Either String Environment
|
|
parseEnvironment "staging" = Right Staging
|
|
parseEnvironment "production" = Right Production
|
|
parseEnvironment other = Left ("unknown environment: " ++ other)
|
|
|
|
parseReplicaCount :: String -> Either String Int
|
|
parseReplicaCount rawValue =
|
|
case reads rawValue of
|
|
[(parsedValue, "")]
|
|
| parsedValue > 0 -> Right parsedValue
|
|
| otherwise -> Left "replicas must be greater than zero"
|
|
_ -> Left ("invalid replica count: " ++ rawValue)
|
|
|
|
resolveStrategy :: [(String, String)] -> Either String Strategy
|
|
resolveStrategy assignments = do
|
|
strategyName <- lookupRequired "strategy" assignments
|
|
case strategyName of
|
|
"rolling" ->
|
|
case lookupOptional "canary" assignments of
|
|
Nothing -> Right Rolling
|
|
Just _ -> Left "rolling strategy does not accept a canary percentage"
|
|
"canary" -> do
|
|
rawPercent <- lookupRequired "canary" assignments
|
|
percent <-
|
|
case reads rawPercent of
|
|
[(parsedPercent, "")]
|
|
| parsedPercent >= 1 && parsedPercent <= 50 -> Right parsedPercent
|
|
| otherwise -> Left "canary percentage must be between 1 and 50"
|
|
_ -> Left ("invalid canary percentage: " ++ rawPercent)
|
|
Right (Canary percent)
|
|
other -> Left ("unknown strategy: " ++ other)
|
|
|
|
buildReleaseRequest :: [String] -> Either String ReleaseRequest
|
|
buildReleaseRequest rawAssignments = do
|
|
assignments <- traverse parseAssignment rawAssignments
|
|
releaseService <- lookupRequired "service" assignments
|
|
releaseEnvironment <- lookupRequired "env" assignments >>= parseEnvironment
|
|
releaseReplicaCount <- lookupRequired "replicas" assignments >>= parseReplicaCount
|
|
releaseStrategy <- resolveStrategy assignments
|
|
let releaseOwner = lookupOptional "owner" assignments
|
|
pure
|
|
ReleaseRequest
|
|
{ serviceName = releaseService
|
|
, environment = releaseEnvironment
|
|
, replicaCount = releaseReplicaCount
|
|
, strategy = releaseStrategy
|
|
, owner = releaseOwner
|
|
}
|
|
|
|
renderReleaseRequest :: ReleaseRequest -> String
|
|
renderReleaseRequest request =
|
|
intercalate
|
|
", "
|
|
[ "service " ++ serviceName request
|
|
, "env " ++ renderEnvironment (environment request)
|
|
, "replicas " ++ show (replicaCount request)
|
|
, "strategy " ++ renderStrategy (strategy request)
|
|
, renderOwner (owner request)
|
|
]
|
|
|
|
renderEnvironment :: Environment -> String
|
|
renderEnvironment Staging = "staging"
|
|
renderEnvironment Production = "production"
|
|
|
|
renderStrategy :: Strategy -> String
|
|
renderStrategy Rolling = "rolling"
|
|
renderStrategy (Canary percent) = "canary " ++ show percent ++ "%"
|
|
|
|
renderOwner :: Maybe String -> String
|
|
renderOwner Nothing = "owner unassigned"
|
|
renderOwner (Just assignedOwner) = "owner " ++ assignedOwner
|