module BDCS.API.V0(BuildInfo(..),
ComposeBody(..),
ComposeDeleteResponse(..),
ComposeFailedResponse(..),
ComposeFinishedResponse(..),
ComposeInfoResponse(..),
ComposeQueueResponse(..),
ComposeResponse(..),
ComposeStatusResponse(..),
ComposeType(..),
ComposeTypesResponse(..),
Metadata(..),
ModuleName(..),
ModulesListResponse(..),
ModulesInfoResponse(..),
PackageNEVRA(..),
ProjectInfo(..),
ProjectsDepsolveResponse(..),
ProjectsInfoResponse(..),
ProjectsListResponse(..),
RecipesListResponse(..),
RecipesInfoResponse(..),
RecipesChangesResponse(..),
RecipesDiffResponse(..),
RecipesDepsolveResponse(..),
RecipesFreezeResponse(..),
RecipeChanges(..),
RecipeDependencies(..),
SourceInfo(..),
WorkspaceChanges(..),
V0API,
v0ApiServer)
where
import BDCS.API.Compose(ComposeInfo(..), ComposeMsgAsk(..), ComposeMsgResp(..), ComposeStatus(..), UuidStatus(..), deleteCompose, getComposesWithStatus, mkComposeStatus)
import BDCS.API.Config(ServerConfig(..))
import BDCS.API.ComposeConfig(ComposeConfig(..), composeConfigTOML, parseComposeConfig)
import BDCS.API.Customization(processCustomization)
import BDCS.API.Depsolve
import BDCS.API.Error(APIResponse(..), createAPIError, tryIO)
import BDCS.API.QueueStatus(QueueStatus(..), queueStatusText)
import BDCS.API.Recipe
import BDCS.API.Recipes
import BDCS.API.Results(returnImage, returnImageLocation, returnResults)
import BDCS.API.TOMLMediaType
import BDCS.API.Utils(GitLock(..), applyLimits, argify, caseInsensitive, caseInsensitiveT)
import BDCS.API.Workspace
import BDCS.DB
import BDCS.Builds(findBuilds, getBuild)
import BDCS.Export.Types(ExportType(..), exportTypeFromText, exportTypeText, supportedExportTypes)
import BDCS.Groups(getGroupsLike)
import BDCS.Projects(findProject, getProject, getProjectsLike)
import BDCS.Sources(findSources, getSource)
import BDCS.Utils.Either(maybeToEither)
import BDCS.Utils.Monad(concatMapM, mapMaybeM)
import qualified Control.Concurrent.ReadWriteLock as RWL
import Control.Concurrent.STM.TChan(writeTChan)
import Control.Concurrent.STM.TMVar(newEmptyTMVar, readTMVar)
import qualified Control.Exception as CE
import Control.Monad.STM(atomically)
import Control.Monad.Except
import Data.Aeson
import Data.Bifunctor(bimap)
import qualified Data.ByteString.Lazy as LBS
import Data.Either(partitionEithers, rights)
import Data.Int(Int64)
import Data.List(find, sortBy)
import Data.List.Extra(nubOrd)
import Data.Maybe(fromMaybe, mapMaybe)
import Data.String(IsString)
import Data.String.Conversions(ConvertibleStrings, cs)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Time.Clock(UTCTime)
import Database.Persist.Sql
import Data.GI.Base(GError(..))
import Data.UUID.V4(nextRandom)
import GHC.TypeLits(KnownSymbol)
import qualified GI.Ggit as Git
import Servant
import System.Directory(createDirectoryIfMissing)
import System.FilePath.Posix((</>), takeFileName)
defaultBranch :: Maybe String -> T.Text
defaultBranch = maybe "master" cs
unsupportedOutputMsg :: T.Text -> T.Text
unsupportedOutputMsg ty = T.concat [
"Invalid compose type (",
ty,
"), must be one of ",
T.intercalate ", " (map exportTypeText supportedExportTypes)]
filterMapComposeStatus :: MonadIO m => FilePath -> [T.Text] -> m [ComposeStatus]
filterMapComposeStatus dir lst = rights <$> mapM (liftIO . runExceptT . mkComposeStatus dir) lst
type V0API = "projects" :> "list" :> QueryParam "offset" Int
:> QueryParam "limit" Int :> Get '[JSON] ProjectsListResponse
:<|> "projects" :> "info" :> Capture "project_names" String :> Get '[JSON] ProjectsInfoResponse
:<|> "projects" :> "depsolve" :> Capture "project_names" String :> Get '[JSON] ProjectsDepsolveResponse
:<|> "blueprints" :> "list" :> QueryParam "offset" Int
:> QueryParam "limit" Int
:> QueryParam "branch" String
:> Get '[JSON] RecipesListResponse
:<|> "blueprints" :> "info" :> Capture "recipes" String
:> QueryParam "branch" String
:> Get '[JSON] RecipesInfoResponse
:<|> "blueprints" :> "changes" :> Capture "recipes" String
:> QueryParam "offset" Int
:> QueryParam "limit" Int
:> QueryParam "branch" String
:> Get '[JSON] RecipesChangesResponse
:<|> "blueprints" :> "new" :> ReqBody '[JSON, TOML] Recipe
:> QueryParam "branch" String
:> Post '[JSON] APIResponse
:<|> "blueprints" :> "delete" :> Capture "recipe" String
:> QueryParam "branch" String
:> Delete '[JSON] APIResponse
:<|> "blueprints" :> "undo" :> Capture "recipe" String
:> Capture "commit" String
:> QueryParam "branch" String
:> Post '[JSON] APIResponse
:<|> "blueprints" :> "workspace" :> ReqBody '[JSON, TOML] Recipe
:> QueryParam "branch" String
:> Post '[JSON] APIResponse
:<|> "blueprints" :> "workspace" :> Capture "recipe" String
:> QueryParam "branch" String
:> Delete '[JSON] APIResponse
:<|> "blueprints" :> "tag" :> Capture "recipe" String
:> QueryParam "branch" String
:> Post '[JSON] APIResponse
:<|> "blueprints" :> "diff" :> Capture "recipe" String
:> Capture "from_commit" String
:> Capture "to_commit" String
:> QueryParam "branch" String
:> Get '[JSON] RecipesDiffResponse
:<|> "blueprints" :> "depsolve" :> Capture "recipes" String
:> QueryParam "branch" String
:> Get '[JSON] RecipesDepsolveResponse
:<|> "blueprints" :> "freeze" :> Capture "recipes" String
:> QueryParam "branch" String
:> Get '[JSON] RecipesFreezeResponse
:<|> "modules" :> "list" :> QueryParam "offset" Int
:> QueryParam "limit" Int
:> Get '[JSON] ModulesListResponse
:<|> "modules" :> "list" :> Capture "module_names" String
:> QueryParam "offset" Int
:> QueryParam "limit" Int
:> Get '[JSON] ModulesListResponse
:<|> "modules" :> "info" :> Capture "module_names" String
:> Get '[JSON] ModulesInfoResponse
:<|> "compose" :> ReqBody '[JSON] ComposeBody
:> QueryParam "test" Int
:> Post '[JSON] ComposeResponse
:<|> "compose" :> "types" :> Get '[JSON] ComposeTypesResponse
:<|> "compose" :> "queue" :> Get '[JSON] ComposeQueueResponse
:<|> "compose" :> "finished" :> Get '[JSON] ComposeFinishedResponse
:<|> "compose" :> "failed" :> Get '[JSON] ComposeFailedResponse
:<|> "compose" :> "status" :> Capture "uuids" String
:> Get '[JSON] ComposeStatusResponse
:<|> "compose" :> "info" :> Capture "uuid" String
:> Get '[JSON] ComposeInfoResponse
:<|> "compose" :> "cancel" :> Capture "uuid" String
:> Delete '[JSON] APIResponse
:<|> "compose" :> "delete" :> Capture "uuids" String
:> Delete '[JSON] ComposeDeleteResponse
:<|> "compose" :> "logs" :> Capture "uuid" String
:> Get '[OctetStream] (Headers '[Header "Content-Disposition" String] LBS.ByteString)
:<|> "compose" :> "image" :> Capture "uuid" String
:> Get '[OctetStream] (Headers '[Header "Content-Disposition" String] LBS.ByteString)
:<|> "compose" :> "metadata" :> Capture "uuid" String
:> Get '[OctetStream] (Headers '[Header "Content-Disposition" String] LBS.ByteString)
:<|> "compose" :> "results" :> Capture "uuid" String
:> Get '[OctetStream] (Headers '[Header "Content-Disposition" String] LBS.ByteString)
v0ApiServer :: ServerConfig -> Server V0API
v0ApiServer cfg = projectsListH
:<|> projectsInfoH
:<|> projectsDepsolveH
:<|> recipesListH
:<|> recipesInfoH
:<|> recipesChangesH
:<|> recipesNewH
:<|> recipesDeleteH
:<|> recipesUndoH
:<|> recipesWorkspaceH
:<|> recipesWorkspaceDeleteH
:<|> recipesTagH
:<|> recipesDiffH
:<|> recipesDepsolveH
:<|> recipesFreezeH
:<|> modulesListH
:<|> modulesListFilteredH
:<|> modulesInfoH
:<|> composeH
:<|> composeTypesH
:<|> composeQueueH
:<|> composeFinishedH
:<|> composeFailedH
:<|> composeStatusH
:<|> composeInfoH
:<|> composeCancelH
:<|> composeDeleteH
:<|> composeLogsH
:<|> composeImageH
:<|> composeMetadataH
:<|> composeResultsH
where
projectsListH offset limit = projectsList cfg offset limit
projectsInfoH project_names = projectsInfo cfg project_names
projectsDepsolveH project_names = projectsDepsolve cfg project_names
recipesListH offset limit branch = recipesList cfg branch offset limit
recipesInfoH recipes branch = recipesInfo cfg branch recipes
recipesChangesH recipes offset limit branch = recipesChanges cfg branch recipes offset limit
recipesNewH recipe branch = recipesNew cfg branch recipe
recipesDeleteH recipe branch = recipesDelete cfg branch recipe
recipesUndoH recipe commit branch = recipesUndo cfg branch recipe commit
recipesWorkspaceH recipe branch = recipesWorkspace cfg branch recipe
recipesWorkspaceDeleteH recipe branch = recipesWorkspaceDelete cfg branch recipe
recipesTagH recipe branch = recipesTag cfg branch recipe
recipesDiffH recipe from_commit to_commit branch = recipesDiff cfg branch recipe from_commit to_commit
recipesDepsolveH recipes branch = recipesDepsolve cfg branch recipes
recipesFreezeH recipes branch = recipesFreeze cfg branch recipes
modulesListH offset limit = modulesList cfg offset limit "*"
modulesListFilteredH module_names offset limit = modulesList cfg offset limit module_names
modulesInfoH module_names = modulesInfo cfg (T.splitOn "," $ cs module_names)
composeH body test = compose cfg body test
composeTypesH = composeTypes
composeQueueH = composeQueue cfg
composeFinishedH = composeQueueFinished cfg
composeFailedH = composeQueueFailed cfg
composeStatusH uuids = composeStatus cfg (T.splitOn "," $ cs uuids)
composeInfoH uuid = composeInfo cfg uuid
composeCancelH uuid = composeCancel cfg uuid
composeDeleteH uuids = composeDelete cfg (T.splitOn "," $ cs uuids)
composeLogsH uuid = composeLogs cfg uuid
composeImageH uuid = composeImage cfg (cs uuid)
composeMetadataH uuid = composeMetadata cfg (cs uuid)
composeResultsH uuid = composeResults cfg (cs uuid)
data RecipesListResponse = RecipesListResponse {
rlrRecipes :: [T.Text],
rlrOffset :: Int,
rlrLimit :: Int,
rlrTotal :: Int
} deriving (Show, Eq)
instance ToJSON RecipesListResponse where
toJSON RecipesListResponse{..} = object [
"blueprints" .= rlrRecipes
, "offset" .= rlrOffset
, "limit" .= rlrLimit
, "total" .= rlrTotal ]
instance FromJSON RecipesListResponse where
parseJSON = withObject "/blueprints/list response" $ \o -> do
rlrRecipes <- o .: "blueprints"
rlrOffset <- o .: "offset"
rlrLimit <- o .: "limit"
rlrTotal <- o .: "total"
return RecipesListResponse{..}
errorMessage :: (ConvertibleStrings a String, ConvertibleStrings b String) => a -> b -> String
errorMessage name msg = cs name ++ ": " ++ cs msg
recipesList :: ServerConfig -> Maybe String -> Maybe Int -> Maybe Int -> Handler RecipesListResponse
recipesList ServerConfig{..} mbranch moffset mlimit = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do
filenames <- listBranchFiles (gitRepo cfgRepoLock) (defaultBranch mbranch)
let recipes = sortBy caseInsensitiveT $ map (T.dropEnd 5) filenames
return $ RecipesListResponse (applyLimits limit offset recipes) offset limit (length recipes)
where
offset :: Int
offset = fromMaybe 0 moffset
limit :: Int
limit = fromMaybe 20 mlimit
data WorkspaceChanges = WorkspaceChanges {
wcName :: T.Text,
wcChanged :: Bool
} deriving (Show, Eq)
instance ToJSON WorkspaceChanges where
toJSON WorkspaceChanges{..} = object [
"name" .= wcName
, "changed" .= wcChanged ]
instance FromJSON WorkspaceChanges where
parseJSON = withObject "workspace changes" $ \o -> do
wcName <- o .: "name"
wcChanged <- o .: "changed"
return WorkspaceChanges{..}
data RecipesInfoResponse = RecipesInfoResponse {
rirChanges :: [WorkspaceChanges],
rirRecipes :: [Recipe],
rirErrors :: [String]
} deriving (Show, Eq)
instance ToJSON RecipesInfoResponse where
toJSON RecipesInfoResponse{..} = object [
"changes" .= rirChanges
, "blueprints" .= rirRecipes
, "errors" .= rirErrors ]
instance FromJSON RecipesInfoResponse where
parseJSON = withObject "/blueprints/info response" $ \o -> do
rirChanges <- o .: "changes"
rirRecipes <- o .: "blueprints"
rirErrors <- o .: "errors"
return RecipesInfoResponse{..}
recipesInfo :: ServerConfig -> Maybe String -> String -> Handler RecipesInfoResponse
recipesInfo ServerConfig{..} branch recipe_names = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do
let recipe_name_list = map T.pack (argify [recipe_names])
(changes, recipes, errors) <- allRecipeInfo recipe_name_list [] [] []
return $ RecipesInfoResponse changes recipes errors
where
allRecipeInfo :: [T.Text] -> [WorkspaceChanges] -> [Recipe] -> [String] -> IO ([WorkspaceChanges], [Recipe], [String])
allRecipeInfo [] _ _ _ = return ([], [], [])
allRecipeInfo [recipe_name] changes_list recipes_list errors_list =
oneRecipeInfo recipe_name changes_list recipes_list errors_list
allRecipeInfo (recipe_name:xs) changes_list recipes_list errors_list = do
(new_changes, new_recipes, new_errors) <- oneRecipeInfo recipe_name changes_list recipes_list errors_list
allRecipeInfo xs new_changes new_recipes new_errors
oneRecipeInfo :: T.Text -> [WorkspaceChanges] -> [Recipe] -> [String] -> IO ([WorkspaceChanges], [Recipe], [String])
oneRecipeInfo recipe_name changes_list recipes_list errors_list = do
result <- getRecipeInfo cfgRepoLock (defaultBranch branch) recipe_name
return (new_changes result, new_recipes result, new_errors result)
where
new_errors :: Either String (Bool, Recipe) -> [String]
new_errors (Left err) = errorMessage recipe_name err:errors_list
new_errors (Right _) = errors_list
new_changes :: Either String (Bool, Recipe) -> [WorkspaceChanges]
new_changes (Right (changed, _)) = WorkspaceChanges recipe_name changed:changes_list
new_changes (Left _) = changes_list
new_recipes :: Either String (Bool, Recipe) -> [Recipe]
new_recipes (Right (_, recipe)) = recipe:recipes_list
new_recipes (Left _) = recipes_list
getRecipeInfo :: GitLock -> T.Text -> T.Text -> IO (Either String (Bool, Recipe))
getRecipeInfo repoLock branch recipe_name = do
result <- getRecipeAndCommit repoLock branch recipe_name
case result of
Left e -> return $ Left e
Right (changed, (_, recipe)) -> return $ Right (changed, recipe)
getRecipeAndCommit :: GitLock -> T.Text -> T.Text -> IO (Either String (Bool, (T.Text, Recipe)))
getRecipeAndCommit repoLock branch recipe_name = do
ws_recipe <- catch_ws_recipe
git_recipe <- catch_git_recipe
case (ws_recipe, git_recipe) of
(Nothing, Left e) -> return $ Left e
(Just recipe, Left _) -> return $ Right (True, ("WORKSPACE", recipe))
(Nothing, Right (commit_id, recipe)) -> return $ Right (False, (commit_id, recipe))
(Just ws_r, Right (commit_id, git_r)) -> return $ commit_result ws_r commit_id git_r
where
commit_result ws_r commit_id git_r = Right (changed, (commit, ws_r))
where
changed = ws_r /= git_r
commit = if changed
then "WORKSPACE"
else commit_id
catch_ws_recipe :: IO (Maybe Recipe)
catch_ws_recipe =
CE.catch (workspaceRead (gitRepo repoLock) branch recipe_name)
(\(_ :: WorkspaceError) -> return Nothing)
catch_git_recipe :: IO (Either String (T.Text, Recipe))
catch_git_recipe =
CE.catches (readRecipeCommit (gitRepo repoLock) branch recipe_name Nothing)
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
data RecipeChanges = RecipeChanges {
rcName :: T.Text,
rcChange :: [CommitDetails],
rcTotal :: Int
} deriving (Show, Eq)
instance ToJSON RecipeChanges where
toJSON RecipeChanges{..} = object [
"name" .= rcName
, "change" .= rcChange
, "total" .= rcTotal ]
instance FromJSON RecipeChanges where
parseJSON = withObject "blueprint changes" $ \o -> do
rcName <- o .: "name"
rcChange <- o .: "change"
rcTotal <- o .: "total"
return RecipeChanges{..}
data RecipesChangesResponse = RecipesChangesResponse {
rcrRecipes :: [RecipeChanges],
rcrErrors :: [String],
rcrOffset :: Int,
rcrLimit :: Int
} deriving (Show, Eq)
instance ToJSON RecipesChangesResponse where
toJSON RecipesChangesResponse{..} = object [
"blueprints" .= rcrRecipes
, "errors" .= rcrErrors
, "offset" .= rcrOffset
, "limit" .= rcrLimit ]
instance FromJSON RecipesChangesResponse where
parseJSON = withObject "/blueprints/changes/ response" $ \o -> do
rcrRecipes <- o .: "blueprints"
rcrErrors <- o .: "errors"
rcrOffset <- o .: "offset"
rcrLimit <- o .: "limit"
return RecipesChangesResponse{..}
recipesChanges :: ServerConfig -> Maybe String -> String -> Maybe Int -> Maybe Int -> Handler RecipesChangesResponse
recipesChanges ServerConfig{..} mbranch recipe_names moffset mlimit = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do
let recipe_name_list = map T.pack (argify [recipe_names])
(changes, errors) <- allRecipeChanges recipe_name_list [] []
return $ RecipesChangesResponse changes errors offset limit
where
allRecipeChanges :: [T.Text] -> [RecipeChanges] -> [String] -> IO ([RecipeChanges], [String])
allRecipeChanges [] _ _ = return ([], [])
allRecipeChanges [recipe_name] changes_list errors_list =
oneRecipeChange recipe_name changes_list errors_list
allRecipeChanges (recipe_name:xs) changes_list errors_list = do
(new_changes, new_errors) <- oneRecipeChange recipe_name changes_list errors_list
allRecipeChanges xs new_changes new_errors
oneRecipeChange :: T.Text -> [RecipeChanges] -> [String] -> IO ([RecipeChanges], [String])
oneRecipeChange recipe_name changes_list errors_list = do
result <- catch_recipe_changes recipe_name
return (new_changes result, new_errors result)
where
new_changes :: Either String [CommitDetails] -> [RecipeChanges]
new_changes (Right changes) = RecipeChanges recipe_name (applyLimits limit offset changes) (length $ applyLimits limit offset changes):changes_list
new_changes (Left _) = changes_list
new_errors :: Either String [CommitDetails] -> [String]
new_errors (Left err) = errorMessage recipe_name err:errors_list
new_errors (Right _) = errors_list
offset :: Int
offset = fromMaybe 0 moffset
limit :: Int
limit = fromMaybe 20 mlimit
catch_recipe_changes :: T.Text -> IO (Either String [CommitDetails])
catch_recipe_changes recipe_name =
CE.catches (Right <$> listRecipeCommits (gitRepo cfgRepoLock) (defaultBranch mbranch) recipe_name)
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
recipesNew :: ServerConfig -> Maybe String -> Recipe -> Handler APIResponse
recipesNew ServerConfig{..} mbranch recipe = do
result <- liftIO $ RWL.withWrite (gitRepoLock cfgRepoLock) catch_recipe_new
case result of
Left err -> throwError $ createAPIError err400 False [errorMessage ("Unknown:" :: String) err]
Right _ -> return $ APIResponse True []
where
catch_recipe_new :: IO (Either String Git.OId)
catch_recipe_new =
CE.catches (Right <$> commitRecipe (gitRepo cfgRepoLock) (defaultBranch mbranch) recipe)
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
recipesDelete :: ServerConfig -> Maybe String -> String -> Handler APIResponse
recipesDelete ServerConfig{..} mbranch recipe_name = do
result <- liftIO $ RWL.withWrite (gitRepoLock cfgRepoLock) catch_recipe_delete
case result of
Left err -> throwError $ createAPIError err400 False [errorMessage recipe_name err]
Right _ -> return $ APIResponse True []
where
catch_recipe_delete :: IO (Either String Git.OId)
catch_recipe_delete =
CE.catches (Right <$> deleteRecipe (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name))
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
recipesUndo :: ServerConfig -> Maybe String -> String -> String -> Handler APIResponse
recipesUndo ServerConfig{..} mbranch recipe_name commit = do
result <- liftIO $ RWL.withWrite (gitRepoLock cfgRepoLock) catch_recipe_undo
case result of
Left err -> throwError $ createAPIError err400 False [errorMessage recipe_name err]
Right _ -> return $ APIResponse True []
where
catch_recipe_undo :: IO (Either String Git.OId)
catch_recipe_undo =
CE.catches (Right <$> revertRecipe (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name) (T.pack commit))
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
recipesWorkspace :: ServerConfig -> Maybe String -> Recipe -> Handler APIResponse
recipesWorkspace ServerConfig{..} mbranch recipe = do
result <- liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) catch_recipe_ws
case result of
Left err -> throwError $ createAPIError err400 False [errorMessage ("Unknown: " :: String) err]
Right _ -> return $ APIResponse True []
where
catch_recipe_ws :: IO (Either String ())
catch_recipe_ws =
CE.catches (Right <$> workspaceWrite (gitRepo cfgRepoLock) (defaultBranch mbranch) recipe)
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
recipesWorkspaceDelete :: ServerConfig -> Maybe String -> String -> Handler APIResponse
recipesWorkspaceDelete ServerConfig{..} mbranch recipe_name = do
result <- liftIO $ RWL.withWrite (gitRepoLock cfgRepoLock) catch_recipe_delete
case result of
Left err -> throwError $ createAPIError err400 False [errorMessage recipe_name err]
Right _ -> return $ APIResponse True []
where
catch_recipe_delete :: IO (Either String ())
catch_recipe_delete =
CE.catches (Right <$> workspaceDelete (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name))
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
recipesTag :: ServerConfig -> Maybe String -> String -> Handler APIResponse
recipesTag ServerConfig{..} mbranch recipe_name = do
result <- liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) catch_recipe_tag
case result of
Left err -> throwError $ createAPIError err400 False ["Unknown: " ++ cs err]
Right status -> return $ APIResponse status []
where
catch_recipe_tag :: IO (Either String Bool)
catch_recipe_tag =
CE.catches (Right <$> tagRecipeCommit (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name))
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
data RecipesDiffResponse = RecipesDiffResponse {
rdrDiff :: [RecipeDiffEntry]
} deriving (Eq, Show)
instance ToJSON RecipesDiffResponse where
toJSON RecipesDiffResponse{..} = object [
"diff" .= rdrDiff ]
instance FromJSON RecipesDiffResponse where
parseJSON = withObject "/blueprints/diff response" $ \o -> do
rdrDiff <- o .: "diff"
return RecipesDiffResponse{..}
recipesDiff :: ServerConfig -> Maybe String -> String -> String -> String -> Handler RecipesDiffResponse
recipesDiff ServerConfig{..} mbranch recipe_name from_commit to_commit = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do
old_recipe <- get_recipe from_commit
new_recipe <- get_recipe to_commit
case (old_recipe, new_recipe) of
(Left _, _) -> return $ RecipesDiffResponse []
(_, Left _) -> return $ RecipesDiffResponse []
(Right (_, o), Right (_, n)) -> do
let diff = recipeDiff o n
return $ RecipesDiffResponse diff
where
get_recipe :: String -> IO (Either String (T.Text, Recipe))
get_recipe "NEWEST" = catch_git_recipe (T.pack recipe_name) Nothing
get_recipe "WORKSPACE" = do
ws_recipe <- catch_ws_recipe (T.pack recipe_name)
case ws_recipe of
Just recipe -> return $ Right ("WORKSPACE", recipe)
Nothing -> get_recipe "NEWEST"
get_recipe commit = catch_git_recipe (T.pack recipe_name) (Just $ T.pack commit)
catch_ws_recipe :: T.Text -> IO (Maybe Recipe)
catch_ws_recipe name =
CE.catch (workspaceRead (gitRepo cfgRepoLock) (defaultBranch mbranch) name)
(\(_ :: WorkspaceError) -> return Nothing)
catch_git_recipe :: T.Text -> Maybe T.Text -> IO (Either String (T.Text, Recipe))
catch_git_recipe name commit =
CE.catches (readRecipeCommit (gitRepo cfgRepoLock) (defaultBranch mbranch) name commit)
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
data RecipeDependencies = RecipeDependencies {
rdRecipe :: Recipe,
rdDependencies :: [PackageNEVRA],
rdModules :: [PackageNEVRA]
} deriving (Show, Eq)
instance ToJSON RecipeDependencies where
toJSON RecipeDependencies{..} = object [
"blueprint" .= rdRecipe
, "dependencies" .= rdDependencies
, "modules" .= rdModules ]
instance FromJSON RecipeDependencies where
parseJSON = withObject "blueprint dependencies" $ \o -> do
rdRecipe <- o .: "blueprint"
rdDependencies <- o .: "dependencies"
rdModules <- o .: "modules"
return RecipeDependencies{..}
data RecipesDepsolveResponse = RecipesDepsolveResponse {
rdrRecipes :: [RecipeDependencies],
rdrErrors :: [String]
} deriving (Show, Eq)
instance ToJSON RecipesDepsolveResponse where
toJSON RecipesDepsolveResponse{..} = object [
"blueprints" .= rdrRecipes
, "errors" .= rdrErrors ]
instance FromJSON RecipesDepsolveResponse where
parseJSON = withObject "/blueprints/depsolve response" $ \o -> do
rdrRecipes <- o .: "blueprints"
rdrErrors <- o .: "errors"
return RecipesDepsolveResponse{..}
recipesDepsolve :: ServerConfig -> Maybe String -> String -> Handler RecipesDepsolveResponse
recipesDepsolve ServerConfig{..} mbranch recipe_names = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do
let recipe_name_list = map T.pack (argify [recipe_names])
(recipes, errors) <- liftIO $ allRecipeDeps recipe_name_list
return $ RecipesDepsolveResponse recipes errors
where
allRecipeDeps :: [T.Text] -> IO ([RecipeDependencies], [String])
allRecipeDeps recipeNames = do
results <- mapM (getOneRecipeInfo cfgRepoLock (defaultBranch mbranch)) recipeNames
let (errors, recipes) = partitionEithers results
results' <- mapM (\r -> bimap (toRecipesAPIError r)
(toRecipeDependencies r)
<$> depsolveRecipe cfgPool r)
recipes
let (depErrors, deps) = partitionEithers results'
return (deps, errors ++ depErrors)
toRecipesAPIError :: Recipe -> T.Text -> String
toRecipesAPIError Recipe{..} msg = errorMessage rName msg
toRecipeDependencies :: Recipe -> ([PackageNEVRA], [PackageNEVRA]) -> RecipeDependencies
toRecipeDependencies recipe (deps, mods) =
RecipeDependencies { rdRecipe=recipe, rdDependencies=deps, rdModules=mods }
getOneRecipeInfo :: GitLock -> T.Text -> T.Text -> IO (Either String Recipe)
getOneRecipeInfo lock branch name =
getRecipeInfo lock branch name >>= \case
Left err -> return $ Left $ errorMessage name err
Right (_, r) -> return $ Right r
data RecipesFreezeResponse = RecipesFreezeResponse {
rfrRecipes :: [Recipe],
rfrErrors :: [String]
} deriving (Show, Eq)
instance ToJSON RecipesFreezeResponse where
toJSON RecipesFreezeResponse{..} = object [
"blueprints" .= rfrRecipes
, "errors" .= rfrErrors ]
instance FromJSON RecipesFreezeResponse where
parseJSON = withObject "/blueprints/freeze response" $ \o -> do
rfrRecipes <- o .: "blueprints"
rfrErrors <- o .: "errors"
return RecipesFreezeResponse{..}
recipesFreeze :: ServerConfig -> Maybe String -> String -> Handler RecipesFreezeResponse
recipesFreeze ServerConfig{..} mbranch recipe_names = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do
let recipe_name_list = map T.pack (argify [recipe_names])
(recipes, errors) <- liftIO $ allRecipeDeps recipe_name_list
return $ RecipesFreezeResponse recipes errors
where
allRecipeDeps :: [T.Text] -> IO ([Recipe], [String])
allRecipeDeps recipeNames = do
results <- mapM (getOneRecipeInfo cfgRepoLock (defaultBranch mbranch)) recipeNames
let (errors, recipes) = partitionEithers results
results' <- mapM (\r -> bimap (toRecipesAPIError r)
(frozenRecipe r)
<$> depsolveRecipe cfgPool r)
recipes
let (depErrors, recipes') = partitionEithers results'
return (recipes', errors ++ depErrors)
toRecipesAPIError :: Recipe -> T.Text -> String
toRecipesAPIError Recipe{..} msg = errorMessage rName msg
getOneRecipeInfo :: GitLock -> T.Text -> T.Text -> IO (Either String Recipe)
getOneRecipeInfo lock branch name =
getRecipeInfo lock branch name >>= \case
Left err -> return $ Left $ errorMessage name err
Right (_, r) -> return $ Right r
frozenRecipe :: Recipe -> ([PackageNEVRA], [PackageNEVRA]) -> Recipe
frozenRecipe recipe (dep_nevras, _) = do
let new_modules = getFrozenModules (rModules recipe) dep_nevras
let new_packages= getFrozenModules (rPackages recipe) dep_nevras
recipe { rModules = new_modules, rPackages = new_packages }
getFrozenModules :: [RecipeModule] -> [PackageNEVRA] -> [RecipeModule]
getFrozenModules recipe_modules all_nevras = mapMaybe (getFrozenRecipeModule all_nevras) recipe_modules
getFrozenRecipeModule :: [PackageNEVRA] -> RecipeModule -> Maybe RecipeModule
getFrozenRecipeModule all_nevras recipe_module =
lookupRecipeModule recipe_module all_nevras >>= \module_nevra ->
Just (frozenRecipeModule recipe_module module_nevra)
lookupRecipeModule :: RecipeModule -> [PackageNEVRA] -> Maybe PackageNEVRA
lookupRecipeModule recipe_module all_nevras = find (\e -> pnName e == T.pack (rmName recipe_module)) all_nevras
frozenRecipeModule :: RecipeModule -> PackageNEVRA -> RecipeModule
frozenRecipeModule rm pn = rm { rmVersion = getVersionFromNEVRA pn }
getVersionFromNEVRA :: PackageNEVRA -> String
getVersionFromNEVRA nevra = T.unpack $ T.concat [epoch $ pnEpoch nevra, pnVersion nevra, "-", pnRelease nevra]
where
epoch Nothing = ""
epoch (Just e) = T.pack (show e) `T.append` ":"
data ProjectsListResponse = ProjectsListResponse {
plpProjects :: [Projects],
plpOffset :: Int,
plpLimit :: Int,
plpTotal :: Int
} deriving (Show, Eq)
instance ToJSON ProjectsListResponse where
toJSON ProjectsListResponse{..} = object [
"projects" .= plpProjects
, "offset" .= plpOffset
, "limit" .= plpLimit
, "total" .= plpTotal ]
instance FromJSON ProjectsListResponse where
parseJSON = withObject "/projects/list response" $ \o -> do
plpProjects <- o .: "projects"
plpOffset <- o .: "offset"
plpLimit <- o .: "limit"
plpTotal <- o .: "total"
return ProjectsListResponse{..}
projectsList :: ServerConfig -> Maybe Int -> Maybe Int -> Handler ProjectsListResponse
projectsList ServerConfig{..} moffset mlimit = do
result <- runExceptT $ runSqlPool (getProjectsLike offset64 limit64 "%") cfgPool
case result of
Left _ -> return $ ProjectsListResponse [] offset limit 0
Right (project_info, total64) -> return $ ProjectsListResponse project_info offset limit (fromIntegral total64)
where
offset :: Int
offset = fromMaybe 0 moffset
limit :: Int
limit = fromMaybe 20 mlimit
offset64 :: Maybe Int64
offset64 = Just $ fromIntegral $ fromMaybe 0 moffset
limit64 :: Maybe Int64
limit64 = Just $ fromIntegral $ fromMaybe 20 mlimit
data Metadata = Metadata {
mdKey :: T.Text,
mdVal :: T.Text
} deriving (Show, Eq)
instance ToJSON Metadata where
toJSON Metadata{..} = object [
"key" .= mdKey,
"val" .= mdVal ]
instance FromJSON Metadata where
parseJSON = withObject "/projects/info metadata" $ \o ->
Metadata <$> o .: "key"
<*> o .: "val"
data SourceInfo = SourceInfo {
siLicense :: T.Text,
siMetadata :: [Metadata],
siSourceRef :: T.Text,
siVersion :: T.Text
} deriving (Show, Eq)
instance ToJSON SourceInfo where
toJSON SourceInfo{..} = object [
"license" .= siLicense,
"metadata" .= siMetadata,
"source_ref" .= siSourceRef,
"version" .= siVersion ]
instance FromJSON SourceInfo where
parseJSON = withObject "/projects/info source info" $ \o ->
SourceInfo <$> o .: "license"
<*> o .: "metadata"
<*> o .: "source_ref"
<*> o .: "version"
data BuildInfo = BuildInfo {
biArch :: T.Text,
biConfigRef :: T.Text,
biEnvRef :: T.Text,
biBuildTime :: UTCTime,
biChangelog :: T.Text,
biEpoch :: Maybe Int,
biMetadata :: [Metadata],
biRelease :: T.Text,
biSource :: SourceInfo
} deriving (Show, Eq)
instance ToJSON BuildInfo where
toJSON BuildInfo{..} = object [
"arch" .= biArch,
"build_config_ref" .= biConfigRef,
"build_env_ref" .= biEnvRef,
"build_time" .= biBuildTime,
"changelog" .= biChangelog,
"epoch" .= biEpoch,
"metadata" .= biMetadata,
"release" .= biRelease,
"source" .= biSource ]
instance FromJSON BuildInfo where
parseJSON = withObject "/projects/info build info" $ \o ->
BuildInfo <$> o .: "arch"
<*> o .: "build_config_ref"
<*> o .: "build_env_ref"
<*> o .: "build_time"
<*> o .: "changelog"
<*> o .: "epoch"
<*> o .: "metadata"
<*> o .: "release"
<*> o .: "source"
data ProjectInfo = ProjectInfo {
piBuilds :: [BuildInfo],
piDescription :: T.Text,
piHomepage :: Maybe T.Text,
piName :: T.Text,
piSummary :: T.Text,
piUpstream :: Maybe T.Text
} deriving (Show, Eq)
instance ToJSON ProjectInfo where
toJSON ProjectInfo{..} = object [
"builds" .= piBuilds,
"description" .= piDescription,
"homepage" .= piHomepage,
"name" .= piName,
"summary" .= piSummary,
"upstream_vcs" .= piUpstream ]
instance FromJSON ProjectInfo where
parseJSON = withObject "/projects/info project info" $ \o ->
ProjectInfo <$> o .: "builds"
<*> o .: "description"
<*> o .: "homepage"
<*> o .: "name"
<*> o .: "summary"
<*> o .: "upstream_vcs"
data ProjectsInfoResponse = ProjectsInfoResponse {
pipProjects :: [ProjectInfo]
} deriving (Show, Eq)
instance ToJSON ProjectsInfoResponse where
toJSON ProjectsInfoResponse{..} = object [
"projects" .= pipProjects ]
instance FromJSON ProjectsInfoResponse where
parseJSON = withObject "/projects/info response" $ \o ->
ProjectsInfoResponse <$> o .: "projects"
projectsInfo :: ServerConfig -> String -> Handler ProjectsInfoResponse
projectsInfo ServerConfig{..} project_names = do
let project_name_list = map T.pack $ sortBy caseInsensitive $ argify [project_names]
results <- liftIO $ mapM (runExceptT . getProjectInfo) project_name_list
return $ ProjectsInfoResponse (rights results)
where
getProjectInfo :: T.Text -> ExceptT String IO ProjectInfo
getProjectInfo project_name = do
(projKey, proj) <- fetchProjects project_name
sources <- fetchSources projKey
tuples <- mapM combineSourceAndBuilds sources
let nfos = concatMap (\(src, blds) -> map (mkBuildInfo src) blds) tuples
return ProjectInfo { piBuilds=nfos,
piDescription=projectsDescription proj,
piHomepage=projectsHomepage proj,
piName=projectsName proj,
piSummary=projectsSummary proj,
piUpstream=projectsUpstream_vcs proj }
where
combineSourceAndBuilds :: (Key Sources, Sources) -> ExceptT e IO (Sources, [Builds])
combineSourceAndBuilds (key, src) = do
builds <- fetchBuilds key
return (src, builds)
mkBuildInfo :: Sources -> Builds -> BuildInfo
mkBuildInfo src Builds{..} =
BuildInfo { biArch=buildsArch,
biConfigRef=buildsBuild_config_ref,
biEnvRef=buildsBuild_env_ref,
biBuildTime=buildsBuild_time,
biChangelog=cs buildsChangelog,
biEpoch=if buildsEpoch == 0 then Nothing else Just buildsEpoch,
biMetadata=[],
biRelease=buildsRelease,
biSource=mkSourceInfo src }
mkSourceInfo :: Sources -> SourceInfo
mkSourceInfo Sources{..} =
SourceInfo { siLicense=sourcesLicense,
siMetadata=[],
siSourceRef=sourcesSource_ref,
siVersion=sourcesVersion }
fetchProjects :: IsString e => T.Text -> ExceptT e IO (Key Projects, Projects)
fetchProjects project_name = flip runSqlPool cfgPool $ do
key <- findProject project_name >>= maybeToEither "no project record with given name"
proj <- getProject key >>= maybeToEither "no project record with given name"
return (key, proj)
fetchSources :: Key Projects -> ExceptT e IO [(Key Sources, Sources)]
fetchSources projectId = flip runSqlPool cfgPool $ do
keys <- findSources projectId
sources <- mapM getSource keys
return $ mapMaybe removeEmptySource (zip keys sources)
where
removeEmptySource :: (Key Sources, Maybe Sources) -> Maybe (Key Sources, Sources)
removeEmptySource (_, Nothing) = Nothing
removeEmptySource (key, Just src) = Just (key, src)
fetchBuilds :: Key Sources -> ExceptT e IO [Builds]
fetchBuilds sourceId = flip runSqlPool cfgPool $
findBuilds sourceId >>= mapMaybeM getBuild
data ProjectsDepsolveResponse = ProjectsDepsolveResponse {
pdrProjects :: [PackageNEVRA]
} deriving (Show, Eq)
instance ToJSON ProjectsDepsolveResponse where
toJSON ProjectsDepsolveResponse{..} = object [
"projects" .= pdrProjects ]
instance FromJSON ProjectsDepsolveResponse where
parseJSON = withObject "/projects/depsolve response" $ \o -> do
pdrProjects <- o .: "projects"
return ProjectsDepsolveResponse{..}
projectsDepsolve :: ServerConfig -> String -> Handler ProjectsDepsolveResponse
projectsDepsolve ServerConfig{..} project_names = do
let project_name_list = map T.pack (argify [project_names])
liftIO $ depsolveProjects cfgPool project_name_list >>= \case
Left _ -> return $ ProjectsDepsolveResponse []
Right project_deps -> return $ ProjectsDepsolveResponse project_deps
data ModuleName = ModuleName {
mnName :: T.Text,
mnGroupType :: T.Text
} deriving (Show, Eq)
instance ToJSON ModuleName where
toJSON ModuleName{..} = object [
"name" .= mnName,
"group_type" .= mnGroupType ]
instance FromJSON ModuleName where
parseJSON = withObject "module info" $ \o -> do
mnName <- o .: "name"
mnGroupType <- o .: "group_type"
return ModuleName{..}
mkModuleName :: T.Text -> ModuleName
mkModuleName name = ModuleName { mnName=name, mnGroupType="rpm" }
data ModulesListResponse = ModulesListResponse {
mlrModules :: [ModuleName],
mlrOffset :: Int,
mlrLimit :: Int,
mlrTotal :: Int
} deriving (Show, Eq)
instance ToJSON ModulesListResponse where
toJSON ModulesListResponse{..} = object [
"modules" .= mlrModules
, "offset" .= mlrOffset
, "limit" .= mlrLimit
, "total" .= mlrTotal ]
instance FromJSON ModulesListResponse where
parseJSON = withObject "/modules/list response" $ \o -> do
mlrModules <- o .: "modules"
mlrOffset <- o .: "offset"
mlrLimit <- o .: "limit"
mlrTotal <- o .: "total"
return ModulesListResponse{..}
modulesList :: ServerConfig -> Maybe Int -> Maybe Int -> String -> Handler ModulesListResponse
modulesList ServerConfig{..} moffset mlimit "*" = do
result <- runExceptT $ flip runSqlPool cfgPool $ getGroupsLike offset64 limit64 "%"
case result of
Left _ ->
return $ ModulesListResponse [] offset limit 0
Right (tuples, total64) ->
let names = nubOrd $ map snd tuples
objs = map mkModuleName names
in return $ ModulesListResponse objs offset limit (fromIntegral total64)
where
offset :: Int
offset = fromMaybe 0 moffset
limit :: Int
limit = fromMaybe 20 mlimit
offset64 :: Maybe Int64
offset64 = Just $ fromIntegral $ fromMaybe 0 moffset
limit64 :: Maybe Int64
limit64 = Just $ fromIntegral $ fromMaybe 20 mlimit
modulesList ServerConfig{..} moffset mlimit module_names = do
let module_names_list = map T.pack $ argify [map (\c -> if c == '*' then '%' else c) module_names]
result <- runExceptT $ flip runSqlPool cfgPool $ concatMapM (fmap fst . getGroupsLike Nothing Nothing) module_names_list
case result of
Left _ -> return $ ModulesListResponse [] offset limit 0
Right tuples -> let names = nubOrd $ sortBy caseInsensitiveT $ map snd tuples
total = length names
objs = applyLimits limit offset $ map mkModuleName names
in return $ ModulesListResponse objs offset limit total
where
offset :: Int
offset = fromMaybe 0 moffset
limit :: Int
limit = fromMaybe 20 mlimit
data ModuleInfo = ModuleInfo {
miDependencies :: [PackageNEVRA],
miDescription :: T.Text,
miHomepage :: Maybe T.Text,
miName :: T.Text,
miSummary :: T.Text,
miUpstream :: Maybe T.Text
} deriving (Show, Eq)
instance ToJSON ModuleInfo where
toJSON ModuleInfo{..} = object [
"dependencies" .= miDependencies,
"description" .= miDescription,
"homepage" .= miHomepage,
"name" .= miName,
"summary" .= miSummary,
"upstream_vcs" .= miUpstream ]
instance FromJSON ModuleInfo where
parseJSON = withObject "/modules/info module info" $ \o ->
ModuleInfo <$> o .: "dependencies"
<*> o .: "description"
<*> o .: "homepage"
<*> o .: "name"
<*> o .: "summary"
<*> o .: "upstream_vcs"
data ModulesInfoResponse = ModulesInfoResponse {
mirModules :: [ModuleInfo]
} deriving (Show, Eq)
instance ToJSON ModulesInfoResponse where
toJSON ModulesInfoResponse{..} = object [
"modules" .= mirModules ]
instance FromJSON ModulesInfoResponse where
parseJSON = withObject "/modules/info response" $ \o ->
ModulesInfoResponse <$> o .: "modules"
modulesInfo :: ServerConfig -> [T.Text] -> Handler ModulesInfoResponse
modulesInfo cfg@ServerConfig{..} modules = do
projectInfos <- concatMap pipProjects <$> mapM getProjectsInfo modules
depResults <- mapM getDependencies projectInfos
return ModulesInfoResponse { mirModules=map (\(pI, deps) -> addDependencies deps (projectInfoToModuleInfo pI))
(zip projectInfos depResults) }
where
addDependencies :: [PackageNEVRA] -> ModuleInfo -> ModuleInfo
addDependencies deps mI = mI { miDependencies=deps }
getDependencies :: ProjectInfo -> Handler [PackageNEVRA]
getDependencies ProjectInfo{..} = removeSelfDep piName . pdrProjects <$> projectsDepsolve cfg (cs piName)
getProjectsInfo :: T.Text -> Handler ProjectsInfoResponse
getProjectsInfo name = projectsInfo cfg (cs name)
removeSelfDep :: T.Text -> [PackageNEVRA] -> [PackageNEVRA]
removeSelfDep name nevras =
filter (\PackageNEVRA{..} -> pnName /= name) nevras
projectInfoToModuleInfo :: ProjectInfo -> ModuleInfo
projectInfoToModuleInfo ProjectInfo{..} =
ModuleInfo { miDependencies=[],
miDescription=piDescription,
miHomepage=piHomepage,
miName=piName,
miSummary=piSummary,
miUpstream=piUpstream }
data ComposeBody = ComposeBody {
cbName :: T.Text,
cbType :: T.Text,
cbBranch :: Maybe T.Text
} deriving (Show, Eq)
instance ToJSON ComposeBody where
toJSON ComposeBody{..} = object [
"blueprint_name" .= cbName
, "compose_type" .= cbType
, "branch" .= fromMaybe "master" cbBranch ]
instance FromJSON ComposeBody where
parseJSON = withObject "compose" $ \o -> do
cbName <- o .: "blueprint_name"
cbType <- o .: "compose_type"
cbBranch <- o .:? "branch"
return ComposeBody{..}
data ComposeResponse = ComposeResponse {
crStatus :: Bool,
crBuildID :: T.Text
} deriving (Show, Eq)
instance ToJSON ComposeResponse where
toJSON ComposeResponse{..} = object [
"status" .= crStatus
, "build_id" .= crBuildID ]
instance FromJSON ComposeResponse where
parseJSON = withObject "/compose response" $ \o -> do
crStatus <- o .: "status"
crBuildID <- o .: "build_id"
return ComposeResponse{..}
compose :: ServerConfig -> ComposeBody -> Maybe Int -> Handler ComposeResponse
compose cfg@ServerConfig{..} ComposeBody{..} _test = case exportTypeFromText cbType of
Nothing -> throwError unsupportedOutput
Just ty -> withRecipe cfgRepoLock cbBranch cbName $ \commit_id recipe -> do
buildId <- liftIO nextRandom
let resultsDir = cfgResultsDir </> show buildId
liftIO $ do
createDirectoryIfMissing True resultsDir
TIO.writeFile (resultsDir </> "STATUS") (queueStatusText QWaiting)
TIO.writeFile (resultsDir </> "blueprint.toml") (recipeTOML recipe)
TIO.writeFile (resultsDir </> "compose.toml") (composeConfigTOML $ ComposeConfig commit_id ty)
withFrozenRecipe cbBranch cbName $ \frozen -> liftIO $ do
TIO.writeFile (resultsDir </> "frozen.toml") (recipeTOML frozen)
customActions <- processCustomization $ rCustomization frozen
let dest = resultsDir </> "compose." ++ T.unpack cbType
ci = ComposeInfo { ciDest=dest,
ciId=T.pack $ show buildId,
ciRecipe=recipe,
ciResultsDir=resultsDir,
ciCustom=customActions,
ciType=ty }
liftIO $ atomically $ writeTChan cfgChan (AskCompose ci, Nothing)
return $ ComposeResponse True (T.pack $ show buildId)
where
unsupportedOutput = createAPIError err400 False [errorMessage ("compose" :: String) (unsupportedOutputMsg cbType)]
withRecipe :: GitLock -> Maybe T.Text -> T.Text -> (T.Text -> Recipe -> Handler ComposeResponse) -> Handler ComposeResponse
withRecipe lock branch name fn =
liftIO (getRecipeAndCommit lock (defaultBranch $ fmap cs branch) name) >>= \case
Left err -> throwError $ createAPIError err400 False [err]
Right (_, (commit_id, recipe)) -> fn commit_id recipe
withFrozenRecipe :: Maybe T.Text -> T.Text -> (Recipe -> Handler ComposeResponse) -> Handler ComposeResponse
withFrozenRecipe branch name fn =
recipesFreeze cfg (fmap cs branch) (cs name) >>= \case
RecipesFreezeResponse [] errs -> throwError $ createAPIError err400 False (map show errs)
RecipesFreezeResponse (frozen:_) _ -> fn frozen
data ComposeType = ComposeType {
ctEnabled :: Bool,
ctName :: T.Text
} deriving (Show, Eq)
instance ToJSON ComposeType where
toJSON ComposeType{..} = object [
"enabled" .= ctEnabled
, "name" .= ctName ]
instance FromJSON ComposeType where
parseJSON = withObject "compose type" $ \o -> do
ctEnabled <- o .: "enabled"
ctName <- o .: "name"
return ComposeType{..}
data ComposeTypesResponse = ComposeTypesResponse {
ctrTypes :: [ComposeType]
} deriving (Show, Eq)
instance ToJSON ComposeTypesResponse where
toJSON ComposeTypesResponse{..} = object [
"types" .= ctrTypes ]
instance FromJSON ComposeTypesResponse where
parseJSON = withObject "/compose/types response" $ \o -> do
ctrTypes <- o .: "types"
return ComposeTypesResponse{..}
composeTypes :: Handler ComposeTypesResponse
composeTypes =
return $ ComposeTypesResponse $ map (ComposeType True . exportTypeText) supportedExportTypes
data ComposeQueueResponse = ComposeQueueResponse {
cqrNew :: [ComposeStatus],
cqrRun :: [ComposeStatus]
} deriving (Show, Eq)
instance ToJSON ComposeQueueResponse where
toJSON ComposeQueueResponse{..} = object [
"new" .= cqrNew
, "run" .= cqrRun ]
instance FromJSON ComposeQueueResponse where
parseJSON = withObject "/compose/queue response" $ \o ->
ComposeQueueResponse <$> o .: "new"
<*> o .: "run"
composeQueue :: ServerConfig -> Handler ComposeQueueResponse
composeQueue ServerConfig{..} = do
r <- liftIO $ atomically newEmptyTMVar
liftIO $ atomically $ writeTChan cfgChan (AskBuildsWaiting, Just r)
buildsWaiting <- liftIO (atomically $ readTMVar r) >>= \case
RespBuildsWaiting lst -> return lst
_ -> return []
r' <- liftIO $ atomically newEmptyTMVar
liftIO $ atomically $ writeTChan cfgChan (AskBuildsInProgress, Just r')
buildsRunning <- liftIO (atomically $ readTMVar r') >>= \case
RespBuildsInProgress lst -> return lst
_ -> return []
waitingCS <- filterMapComposeStatus cfgResultsDir buildsWaiting
runningCS <- filterMapComposeStatus cfgResultsDir buildsRunning
return $ ComposeQueueResponse waitingCS runningCS
data ComposeFinishedResponse = ComposeFinishedResponse {
cfrFinished :: [ComposeStatus]
} deriving (Show, Eq)
instance ToJSON ComposeFinishedResponse where
toJSON ComposeFinishedResponse{..} = object [
"finished" .= cfrFinished ]
instance FromJSON ComposeFinishedResponse where
parseJSON = withObject "/compose/queue/finished response" $ \o ->
ComposeFinishedResponse <$> o .: "finished"
composeQueueFinished :: ServerConfig -> Handler ComposeFinishedResponse
composeQueueFinished ServerConfig{..} = do
results <- liftIO $ getComposesWithStatus cfgResultsDir QFinished
return $ ComposeFinishedResponse results
data ComposeFailedResponse = ComposeFailedResponse {
cfrFailed :: [ComposeStatus]
} deriving (Show, Eq)
instance ToJSON ComposeFailedResponse where
toJSON ComposeFailedResponse{..} = object [
"failed" .= cfrFailed ]
instance FromJSON ComposeFailedResponse where
parseJSON = withObject "/compose/queue/failed response" $ \o ->
ComposeFailedResponse <$> o .: "failed"
composeQueueFailed :: ServerConfig -> Handler ComposeFailedResponse
composeQueueFailed ServerConfig{..} = do
results <- liftIO $ getComposesWithStatus cfgResultsDir QFailed
return $ ComposeFailedResponse results
data ComposeStatusResponse = ComposeStatusResponse {
csrUuids :: [ComposeStatus]
} deriving (Show, Eq)
instance ToJSON ComposeStatusResponse where
toJSON ComposeStatusResponse{..} = object [
"uuids" .= csrUuids ]
instance FromJSON ComposeStatusResponse where
parseJSON = withObject "/compose/queue/status response" $ \o ->
ComposeStatusResponse <$> o .: "uuids"
composeStatus :: ServerConfig -> [T.Text] -> Handler ComposeStatusResponse
composeStatus ServerConfig{..} uuids =
ComposeStatusResponse <$> filterMapComposeStatus cfgResultsDir uuids
data ComposeInfoResponse = ComposeInfoResponse {
cirCommit :: T.Text,
cirBlueprint :: Recipe,
cirType :: ExportType,
cirBuildId :: T.Text,
cirQueueStatus :: T.Text
} deriving (Show, Eq)
instance ToJSON ComposeInfoResponse where
toJSON ComposeInfoResponse{..} = object
[ "commit" .= cirCommit
, "blueprint" .= cirBlueprint
, "compose_type" .= exportTypeText cirType
, "id" .= cirBuildId
, "queue_status" .= cirQueueStatus
]
instance FromJSON ComposeInfoResponse where
parseJSON = withObject "/compose/info response" $ \o -> do
cirCommit <- o .: "commit"
cirBlueprint <- o .: "blueprint"
cirType <- (o .: "compose_type") >>= \et -> return $ fromMaybe ExportTar $ exportTypeFromText et
cirBuildId <- o .: "id"
cirQueueStatus <- o .: "queue_status"
return ComposeInfoResponse{..}
composeInfo :: ServerConfig -> String -> Handler ComposeInfoResponse
composeInfo ServerConfig{..} uuid = do
result <- liftIO $ runExceptT $ do
ComposeStatus{..} <- withExceptT (const invalid_uuid)
(mkComposeStatus cfgResultsDir (cs uuid))
ComposeConfig{..} <- readComposeConfigFile results_dir
recipe <- readFrozenBlueprintFile results_dir
return $ ComposeInfoResponse ccCommit recipe ccExportType (cs uuid) (queueStatusText csQueueStatus)
case result of
Left err -> throwError err
Right r -> return r
where
results_dir = cfgResultsDir </> cs uuid
invalid_uuid = createAPIError err400 False ["compose_info: " ++ cs uuid ++ " is not a valid build uuid"]
config_error = createAPIError err400 False ["compose_info: " ++ cs uuid ++ " had a problem reading the compose.toml file"]
frozen_error = createAPIError err400 False ["compose_info: " ++ cs uuid ++ " had a problem reading the frozen.toml file"]
readComposeConfigFile :: FilePath -> ExceptT ServantErr IO ComposeConfig
readComposeConfigFile dir = withExceptT (const config_error) $
tryIO (TIO.readFile (dir </> "compose.toml")) >>= ExceptT . return . parseComposeConfig
readFrozenBlueprintFile :: FilePath -> ExceptT ServantErr IO Recipe
readFrozenBlueprintFile dir = withExceptT (const frozen_error) $
tryIO (TIO.readFile (dir </> "frozen.toml")) >>= ExceptT . return . parseRecipe
data ComposeDeleteResponse = ComposeDeleteResponse {
cdrErrors :: [String],
cdrUuids :: [UuidStatus]
} deriving (Show, Eq)
instance ToJSON ComposeDeleteResponse where
toJSON ComposeDeleteResponse{..} = object [
"errors" .= cdrErrors,
"uuids" .= cdrUuids ]
instance FromJSON ComposeDeleteResponse where
parseJSON = withObject "/compose/delete response" $ \o ->
ComposeDeleteResponse <$> o .: "errors"
<*> o .: "uuids"
composeCancel :: ServerConfig -> String -> Handler APIResponse
composeCancel ServerConfig{..} uuid = do
result <- liftIO $ runExceptT $ mkComposeStatus cfgResultsDir (cs uuid)
case result of
Left _ -> throwError $ createAPIError err400 False ["compose_cancel: " ++ cs uuid ++ " is not a valid build uuid"]
Right ComposeStatus{..} -> case csQueueStatus of
QWaiting -> do r <- liftIO $ atomically newEmptyTMVar
liftIO $ atomically $ writeTChan cfgChan (AskDequeueBuild csBuildId, Just r)
liftIO (atomically $ readTMVar r) >>= \case
RespBuildDequeued True -> return $ APIResponse True []
_ -> throwError $ createAPIError err400 False ["compose_cancel: " ++ cs uuid ++ " could not be canceled"]
QRunning -> do r <- liftIO $ atomically newEmptyTMVar
liftIO $ atomically $ writeTChan cfgChan (AskCancelBuild csBuildId, Just r)
liftIO (atomically $ readTMVar r) >>= \case
RespBuildCancelled True -> return $ APIResponse True []
_ -> throwError $ createAPIError err400 False ["compose_cancel: " ++ cs uuid ++ "could not be canceled"]
_ -> throwError $ createAPIError err400 False ["compose_cancel: " ++ cs uuid ++ " is not in WAITING or RUNNING"]
composeDelete :: ServerConfig -> [T.Text] -> Handler ComposeDeleteResponse
composeDelete ServerConfig{..} uuids = do
results <- liftIO $ mapM (deleteCompose cfgResultsDir) uuids
let (errors, successes) = partitionEithers results
return ComposeDeleteResponse { cdrErrors=errors, cdrUuids=successes }
composeLogs :: KnownSymbol h => ServerConfig -> String -> Handler (Headers '[Header h String] LBS.ByteString)
composeLogs serverConf uuid =
returnResults serverConf uuid (Just "-logs") ["compose.log"]
composeImage :: KnownSymbol h => ServerConfig -> T.Text -> Handler (Headers '[Header h String] LBS.ByteString)
composeImage serverConf uuid = do
(fn, contents) <- returnImage serverConf (cs uuid)
return $ addHeader ("attachment; filename=" ++ filename fn ++ ";") contents
where
filename fn = cs uuid ++ "-" ++ takeFileName fn
composeMetadata :: KnownSymbol h => ServerConfig -> String -> Handler (Headers '[Header h String] LBS.ByteString)
composeMetadata serverConf uuid =
returnResults serverConf uuid (Just "-metadata") ["blueprint.toml", "compose.toml", "frozen.toml"]
composeResults :: KnownSymbol h => ServerConfig -> String -> Handler (Headers '[Header h String] LBS.ByteString)
composeResults serverConf uuid = do
imageLocation <- returnImageLocation serverConf uuid
case imageLocation of
Just loc -> returnResults serverConf uuid Nothing ["compose.log", "blueprint.toml", "compose.toml", "frozen.toml", takeFileName loc]
Nothing -> throwError $ createAPIError err400 False ["Build " ++ cs uuid ++ " is missing image file."]