module BDCS.API.V0(PackageNEVRA(..),
ProjectsDepsolveResponse(..),
ProjectsInfoResponse(..),
ProjectsListResponse(..),
RecipesListResponse(..),
RecipesInfoResponse(..),
RecipesChangesResponse(..),
RecipesDiffResponse(..),
RecipesDepsolveResponse(..),
RecipesFreezeResponse(..),
RecipesStatusResponse(..),
RecipesAPIError(..),
RecipeChanges(..),
RecipeDependencies(..),
WorkspaceChanges(..),
V0API,
v0ApiServer)
where
import BDCS.API.Error(createApiError)
import BDCS.API.Recipe
import BDCS.API.Recipes
import BDCS.API.TOMLMediaType
import BDCS.API.Utils(GitLock(..), argify, caseInsensitive)
import BDCS.API.Workspace
import BDCS.DB
import BDCS.Depclose(depcloseNames)
import BDCS.Depsolve(formulaToCNF, solveCNF)
import BDCS.Groups(groupIdToNevra)
import BDCS.Projects(findProject, getProject, projects)
import BDCS.RPM.Utils(splitFilename)
import BDCS.Utils.Monad(mapMaybeM)
import qualified Control.Concurrent.ReadWriteLock as RWL
import qualified Control.Exception as CE
import Control.Monad.Except
import Data.Aeson
import Data.List(find, sortBy)
import Data.Maybe(fromMaybe, mapMaybe)
import qualified Data.Text as T
import Database.Persist.Sql
import Data.GI.Base(GError(..))
import qualified GI.Ggit as Git
import Servant
data RecipesAPIError = RecipesAPIError
{ raeRecipe :: T.Text,
raeMsg :: T.Text
} deriving (Eq, Show)
instance ToJSON RecipesAPIError where
toJSON RecipesAPIError{..} = object [
"recipe".= raeRecipe
, "msg" .= raeMsg ]
instance FromJSON RecipesAPIError where
parseJSON = withObject "API Error" $ \o -> do
raeRecipe <- o .: "recipe"
raeMsg <- o .: "msg"
return RecipesAPIError{..}
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
:<|> "errtest" :> Get '[JSON] [T.Text]
:<|> "recipes" :> "list" :> QueryParam "offset" Int
:> QueryParam "limit" Int :> Get '[JSON] RecipesListResponse
:<|> "recipes" :> "info" :> Capture "recipes" String :> Get '[JSON] RecipesInfoResponse
:<|> "recipes" :> "changes" :> Capture "recipes" String
:> QueryParam "offset" Int
:> QueryParam "limit" Int :> Get '[JSON] RecipesChangesResponse
:<|> "recipes" :> "new" :> ReqBody '[JSON, TOML] Recipe :> Post '[JSON] RecipesStatusResponse
:<|> "recipes" :> "delete" :> Capture "recipe" String :> Delete '[JSON] RecipesStatusResponse
:<|> "recipes" :> "undo" :> Capture "recipe" String
:> Capture "commit" String :> Post '[JSON] RecipesStatusResponse
:<|> "recipes" :> "workspace" :> ReqBody '[JSON, TOML] Recipe :> Post '[JSON] RecipesStatusResponse
:<|> "recipes" :> "tag" :> Capture "recipe" String :> Post '[JSON] RecipesStatusResponse
:<|> "recipes" :> "diff" :> Capture "recipe" String
:> Capture "from_commit" String
:> Capture "to_commit" String
:> Get '[JSON] RecipesDiffResponse
:<|> "recipes" :> "depsolve" :> Capture "recipes" String :> Get '[JSON] RecipesDepsolveResponse
:<|> "recipes" :> "freeze" :> Capture "recipes" String :> Get '[JSON] RecipesFreezeResponse
v0ApiServer :: GitLock -> ConnectionPool -> Server V0API
v0ApiServer repoLock pool = projectsListH
:<|> projectsInfoH
:<|> projectsDepsolveH
:<|> errTestH
:<|> recipesListH
:<|> recipesInfoH
:<|> recipesChangesH
:<|> recipesNewH
:<|> recipesDeleteH
:<|> recipesUndoH
:<|> recipesWorkspaceH
:<|> recipesTagH
:<|> recipesDiffH
:<|> recipesDepsolveH
:<|> recipesFreezeH
where
projectsListH offset limit = projectsList pool offset limit
projectsInfoH project_names = projectsInfo pool project_names
projectsDepsolveH project_names = projectsDepsolve pool project_names
errTestH = errTest
recipesListH offset limit = recipesList repoLock "master" offset limit
recipesInfoH recipes = recipesInfo repoLock "master" recipes
recipesChangesH recipes offset limit = recipesChanges repoLock "master" recipes offset limit
recipesNewH recipe = recipesNew repoLock "master" recipe
recipesDeleteH recipe= recipesDelete repoLock "master" recipe
recipesUndoH recipe commit = recipesUndo repoLock "master" recipe commit
recipesWorkspaceH recipe = recipesWorkspace repoLock "master" recipe
recipesTagH recipe = recipesTag repoLock "master" recipe
recipesDiffH recipe from_commit to_commit = recipesDiff repoLock "master" recipe from_commit to_commit
recipesDepsolveH recipes = recipesDepsolve pool repoLock "master" recipes
recipesFreezeH recipes = recipesFreeze pool repoLock "master" recipes
errTest :: Handler [T.Text]
errTest = throwError myError
where
myError :: ServantErr
myError = createApiError err503 "test_api_error" "This is a test of an API Error Response"
data RecipesListResponse = RecipesListResponse {
rlrRecipes :: [T.Text],
rlrOffset :: Int,
rlrLimit :: Int,
rlrTotal :: Int
} deriving (Show, Eq)
instance ToJSON RecipesListResponse where
toJSON RecipesListResponse{..} = object [
"recipes" .= rlrRecipes
, "offset" .= rlrOffset
, "limit" .= rlrLimit
, "total" .= rlrTotal ]
instance FromJSON RecipesListResponse where
parseJSON = withObject "/recipes/list response" $ \o -> do
rlrRecipes <- o .: "recipes"
rlrOffset <- o .: "offset"
rlrLimit <- o .: "limit"
rlrTotal <- o .: "total"
return RecipesListResponse{..}
recipesList :: GitLock -> T.Text -> Maybe Int -> Maybe Int -> Handler RecipesListResponse
recipesList repoLock branch moffset mlimit = liftIO $ RWL.withRead (gitRepoLock repoLock) $ do
filenames <- listBranchFiles (gitRepo repoLock) branch
let recipes = sortBy caseInsensitiveT $ map (T.dropEnd 5) filenames
return $ RecipesListResponse (apply_limits recipes) offset limit (length recipes)
where
caseInsensitiveT a b = T.toCaseFold a `compare` T.toCaseFold b
offset :: Int
offset = fromMaybe 0 moffset
limit :: Int
limit = fromMaybe 20 mlimit
apply_limits :: [a] -> [a]
apply_limits l = take limit $ drop offset l
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 :: [RecipesAPIError]
} deriving (Show, Eq)
instance ToJSON RecipesInfoResponse where
toJSON RecipesInfoResponse{..} = object [
"changes" .= rirChanges
, "recipes" .= rirRecipes
, "errors" .= rirErrors ]
instance FromJSON RecipesInfoResponse where
parseJSON = withObject "/recipes/info response" $ \o -> do
rirChanges <- o .: "changes"
rirRecipes <- o .: "recipes"
rirErrors <- o .: "errors"
return RecipesInfoResponse{..}
recipesInfo :: GitLock -> T.Text -> String -> Handler RecipesInfoResponse
recipesInfo repoLock branch recipe_names = liftIO $ RWL.withRead (gitRepoLock repoLock) $ 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] -> [RecipesAPIError] -> IO ([WorkspaceChanges], [Recipe], [RecipesAPIError])
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] -> [RecipesAPIError] -> IO ([WorkspaceChanges], [Recipe], [RecipesAPIError])
oneRecipeInfo recipe_name changes_list recipes_list errors_list = do
result <- getRecipeInfo repoLock branch recipe_name
return (new_changes result, new_recipes result, new_errors result)
where
new_errors :: Either String (Bool, Recipe) -> [RecipesAPIError]
new_errors (Left err) = RecipesAPIError recipe_name (T.pack 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
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, recipe)
(Nothing, Right recipe) -> return $ Right (False, recipe)
(Just ws_r, Right git_r) -> return $ Right (ws_r == git_r, ws_r)
where
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 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 "recipe changes" $ \o -> do
rcName <- o .: "name"
rcChange <- o .: "change"
rcTotal <- o .: "total"
return RecipeChanges{..}
data RecipesChangesResponse = RecipesChangesResponse {
rcrRecipes :: [RecipeChanges],
rcrErrors :: [RecipesAPIError],
rcrOffset :: Int,
rcrLimit :: Int
} deriving (Show, Eq)
instance ToJSON RecipesChangesResponse where
toJSON RecipesChangesResponse{..} = object [
"recipes" .= rcrRecipes
, "errors" .= rcrErrors
, "offset" .= rcrOffset
, "limit" .= rcrLimit ]
instance FromJSON RecipesChangesResponse where
parseJSON = withObject "/recipes/changes/ response" $ \o -> do
rcrRecipes <- o .: "recipes"
rcrErrors <- o .: "errors"
rcrOffset <- o .: "offset"
rcrLimit <- o .: "limit"
return RecipesChangesResponse{..}
recipesChanges :: GitLock -> T.Text -> String -> Maybe Int -> Maybe Int -> Handler RecipesChangesResponse
recipesChanges repoLock branch recipe_names moffset mlimit = liftIO $ RWL.withRead (gitRepoLock repoLock) $ 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] -> [RecipesAPIError] -> IO ([RecipeChanges], [RecipesAPIError])
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] -> [RecipesAPIError] -> IO ([RecipeChanges], [RecipesAPIError])
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 (apply_limits changes) (length $ apply_limits changes):changes_list
new_changes (Left _) = changes_list
new_errors :: Either String [CommitDetails] -> [RecipesAPIError]
new_errors (Left err) = RecipesAPIError recipe_name (T.pack err):errors_list
new_errors (Right _) = errors_list
offset :: Int
offset = fromMaybe 0 moffset
limit :: Int
limit = fromMaybe 20 mlimit
apply_limits :: [a] -> [a]
apply_limits l = take limit $ drop offset l
catch_recipe_changes :: T.Text -> IO (Either String [CommitDetails])
catch_recipe_changes recipe_name =
CE.catches (Right <$> listRecipeCommits (gitRepo repoLock) branch recipe_name)
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
data RecipesStatusResponse = RecipesStatusResponse {
rsrStatus :: Bool,
rsrErrors :: [RecipesAPIError]
} deriving (Show, Eq)
instance ToJSON RecipesStatusResponse where
toJSON RecipesStatusResponse{..} = object [
"status" .= rsrStatus
, "errors" .= rsrErrors ]
instance FromJSON RecipesStatusResponse where
parseJSON = withObject "/recipes/* status response" $ \o -> do
rsrStatus <- o .: "status"
rsrErrors <- o .: "errors"
return RecipesStatusResponse{..}
recipesNew :: GitLock -> T.Text -> Recipe -> Handler RecipesStatusResponse
recipesNew repoLock branch recipe = liftIO $ RWL.withWrite (gitRepoLock repoLock) $ do
result <- catch_recipe_new
case result of
Left err -> return $ RecipesStatusResponse False [RecipesAPIError "Unknown" (T.pack err)]
Right _ -> return $ RecipesStatusResponse True []
where
catch_recipe_new :: IO (Either String Git.OId)
catch_recipe_new =
CE.catches (Right <$> commitRecipe (gitRepo repoLock) branch recipe)
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
recipesDelete :: GitLock -> T.Text -> String -> Handler RecipesStatusResponse
recipesDelete repoLock branch recipe_name = liftIO $ RWL.withWrite (gitRepoLock repoLock) $ do
result <- catch_recipe_delete
case result of
Left err -> return $ RecipesStatusResponse False [RecipesAPIError (T.pack recipe_name) (T.pack err)]
Right _ -> return $ RecipesStatusResponse True []
where
catch_recipe_delete :: IO (Either String Git.OId)
catch_recipe_delete =
CE.catches (Right <$> deleteRecipe (gitRepo repoLock) branch (T.pack recipe_name))
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
recipesUndo :: GitLock -> T.Text -> String -> String -> Handler RecipesStatusResponse
recipesUndo repoLock branch recipe_name commit = liftIO $ RWL.withWrite (gitRepoLock repoLock) $ do
result <- catch_recipe_undo
case result of
Left err -> return $ RecipesStatusResponse False [RecipesAPIError (T.pack recipe_name) (T.pack err)]
Right _ -> return $ RecipesStatusResponse True []
where
catch_recipe_undo :: IO (Either String Git.OId)
catch_recipe_undo =
CE.catches (Right <$> revertRecipe (gitRepo repoLock) branch (T.pack recipe_name) (T.pack commit))
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
recipesWorkspace :: GitLock -> T.Text -> Recipe -> Handler RecipesStatusResponse
recipesWorkspace repoLock branch recipe = liftIO $ RWL.withRead (gitRepoLock repoLock) $ do
result <- catch_recipe_ws
case result of
Left err -> return $ RecipesStatusResponse False [RecipesAPIError "Unknown" (T.pack err)]
Right _ -> return $ RecipesStatusResponse True []
where
catch_recipe_ws :: IO (Either String ())
catch_recipe_ws =
CE.catches (Right <$> workspaceWrite (gitRepo repoLock) branch recipe)
[CE.Handler (\(e :: GitError) -> return $ Left (show e)),
CE.Handler (\(e :: GError) -> return $ Left (show e))]
recipesTag :: GitLock -> T.Text -> String -> Handler RecipesStatusResponse
recipesTag repoLock branch recipe_name = liftIO $ RWL.withRead (gitRepoLock repoLock) $ do
result <- catch_recipe_tag
case result of
Left err -> return $ RecipesStatusResponse False [RecipesAPIError "Unknown" (T.pack err)]
Right status -> return $ RecipesStatusResponse status []
where
catch_recipe_tag :: IO (Either String Bool)
catch_recipe_tag =
CE.catches (Right <$> tagRecipeCommit (gitRepo repoLock) branch (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 "/recipes/diff response" $ \o -> do
rdrDiff <- o .: "diff"
return RecipesDiffResponse{..}
recipesDiff :: GitLock -> T.Text -> String -> String -> String -> Handler RecipesDiffResponse
recipesDiff repoLock branch recipe_name from_commit to_commit = liftIO $ RWL.withRead (gitRepoLock repoLock) $ 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 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 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 repoLock) branch name)
(\(_ :: WorkspaceError) -> return Nothing)
catch_git_recipe :: T.Text -> Maybe T.Text -> IO (Either String Recipe)
catch_git_recipe name commit =
CE.catches (readRecipeCommit (gitRepo repoLock) branch 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 [
"recipe" .= rdRecipe
, "dependencies" .= rdDependencies
, "modules" .= rdModules ]
instance FromJSON RecipeDependencies where
parseJSON = withObject "recipe dependencies" $ \o -> do
rdRecipe <- o .: "recipe"
rdDependencies <- o .: "dependencies"
rdModules <- o .: "modules"
return RecipeDependencies{..}
data RecipesDepsolveResponse = RecipesDepsolveResponse {
rdrRecipes :: [RecipeDependencies],
rdrErrors :: [RecipesAPIError]
} deriving (Show, Eq)
instance ToJSON RecipesDepsolveResponse where
toJSON RecipesDepsolveResponse{..} = object [
"recipes" .= rdrRecipes
, "errors" .= rdrErrors ]
instance FromJSON RecipesDepsolveResponse where
parseJSON = withObject "/recipes/depsolve response" $ \o -> do
rdrRecipes <- o .: "recipes"
rdrErrors <- o .: "errors"
return RecipesDepsolveResponse{..}
recipesDepsolve :: ConnectionPool -> GitLock -> T.Text -> String -> Handler RecipesDepsolveResponse
recipesDepsolve pool repoLock branch recipe_names = liftIO $ RWL.withRead (gitRepoLock repoLock) $ 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] -> [RecipeDependencies] -> [RecipesAPIError] -> IO ([RecipeDependencies], [RecipesAPIError])
allRecipeDeps [] _ _ = return ([], [])
allRecipeDeps [recipe_name] recipes_list errors_list =
depsolveRecipe recipe_name recipes_list errors_list
allRecipeDeps (recipe_name:xs) recipes_list errors_list = do
(new_recipes, new_errors) <- depsolveRecipe recipe_name recipes_list errors_list
allRecipeDeps xs new_recipes new_errors
depsolveRecipe :: T.Text -> [RecipeDependencies] -> [RecipesAPIError] -> IO ([RecipeDependencies], [RecipesAPIError])
depsolveRecipe recipe_name recipes_list errors_list = getRecipeInfo repoLock branch recipe_name >>= \case
Left err -> return (recipes_list, RecipesAPIError recipe_name (T.pack err):errors_list)
Right (_, recipe) -> do
let projects_name_list = map T.pack $ getAllRecipeProjects recipe
depsolveProjects pool projects_name_list >>= \case
Left err -> return (recipes_list, RecipesAPIError recipe_name (T.pack err):errors_list)
Right dep_nevras -> do
let project_nevras = getProjectNEVRAs projects_name_list dep_nevras
return (RecipeDependencies recipe dep_nevras project_nevras:recipes_list, errors_list)
getProjectNEVRAs :: [T.Text] -> [PackageNEVRA] -> [PackageNEVRA]
getProjectNEVRAs project_names all_nevras = mapMaybe lookupProject project_names
where
lookupProject project_name = find (\e -> pnName e == project_name) all_nevras
data RecipesFreezeResponse = RecipesFreezeResponse {
rfrRecipes :: [Recipe],
rfrErrors :: [RecipesAPIError]
} deriving (Show, Eq)
instance ToJSON RecipesFreezeResponse where
toJSON RecipesFreezeResponse{..} = object [
"recipes" .= rfrRecipes
, "errors" .= rfrErrors ]
instance FromJSON RecipesFreezeResponse where
parseJSON = withObject "/recipes/freeze response" $ \o -> do
rfrRecipes <- o .: "recipes"
rfrErrors <- o .: "errors"
return RecipesFreezeResponse{..}
recipesFreeze :: ConnectionPool -> GitLock -> T.Text -> String -> Handler RecipesFreezeResponse
recipesFreeze pool repoLock branch recipe_names = liftIO $ RWL.withRead (gitRepoLock repoLock) $ 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] -> [Recipe] -> [RecipesAPIError] -> IO ([Recipe], [RecipesAPIError])
allRecipeDeps [] _ _ = return ([], [])
allRecipeDeps [recipe_name] recipes_list errors_list =
depsolveRecipe recipe_name recipes_list errors_list
allRecipeDeps (recipe_name:xs) recipes_list errors_list = do
(new_recipes, new_errors) <- depsolveRecipe recipe_name recipes_list errors_list
allRecipeDeps xs new_recipes new_errors
depsolveRecipe :: T.Text -> [Recipe] -> [RecipesAPIError] -> IO ([Recipe], [RecipesAPIError])
depsolveRecipe recipe_name recipes_list errors_list = do
result <- getRecipeInfo repoLock branch recipe_name
case result of
Left err -> return (recipes_list, RecipesAPIError recipe_name (T.pack err):errors_list)
Right (_, recipe) -> do
let projects_name_list = map T.pack $ getAllRecipeProjects recipe
dep_result <- depsolveProjects pool projects_name_list
case dep_result of
Left err -> return (recipes_list, RecipesAPIError recipe_name (T.pack err):errors_list)
Right dep_nevras -> return (frozenRecipe recipe dep_nevras:recipes_list, errors_list)
frozenRecipe :: Recipe -> [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 (Just e) = e `T.append` ":"
epoch Nothing = ""
data PackageNEVRA = PackageNEVRA {
pnName :: T.Text
, pnEpoch :: Maybe T.Text
, pnVersion :: T.Text
, pnRelease :: T.Text
, pnArch :: T.Text
} deriving (Show, Eq)
instance ToJSON PackageNEVRA where
toJSON PackageNEVRA{..} = object [
"name" .= pnName
, "epoch" .= fromMaybe "0" pnEpoch
, "version" .= pnVersion
, "release" .= pnRelease
, "arch" .= pnArch ]
instance FromJSON PackageNEVRA where
parseJSON = withObject "package NEVRA" $ \o -> do
pnName <- o .: "name"
pnEpoch <- o .: "epoch"
pnVersion <- o .: "version"
pnRelease <- o .: "release"
pnArch <- o .: "arch"
return PackageNEVRA{..}
mkPackageNEVRA :: (T.Text, Maybe T.Text, T.Text, T.Text, T.Text) -> PackageNEVRA
mkPackageNEVRA (name, epoch, version, release, arch) = PackageNEVRA name epoch version release arch
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 :: ConnectionPool -> Maybe Int -> Maybe Int -> Handler ProjectsListResponse
projectsList pool moffset mlimit = do
result <- runExceptT $ runSqlPool projects pool
case result of
Left _ -> return $ ProjectsListResponse [] offset limit 0
Right project_info -> return $ ProjectsListResponse (apply_limits project_info) offset limit (length project_info)
where
offset :: Int
offset = fromMaybe 0 moffset
limit :: Int
limit = fromMaybe 20 mlimit
apply_limits :: [a] -> [a]
apply_limits l = take limit $ drop offset l
data ProjectsInfoResponse = ProjectsInfoResponse {
pipProjects :: [Projects]
} deriving (Show, Eq)
instance ToJSON ProjectsInfoResponse where
toJSON ProjectsInfoResponse{..} = object [
"projects" .= pipProjects ]
instance FromJSON ProjectsInfoResponse where
parseJSON = withObject "/projects/info response" $ \o -> do
pipProjects <- o .: "projects"
return ProjectsInfoResponse{..}
projectsInfo :: ConnectionPool -> String -> Handler ProjectsInfoResponse
projectsInfo pool project_names = do
let project_name_list = map T.pack $ sortBy caseInsensitive $ argify [project_names]
projects_info <- liftIO $ mapMaybeM getProjectInfo project_name_list
return $ ProjectsInfoResponse projects_info
where
getProjectInfo :: T.Text -> IO (Maybe Projects)
getProjectInfo project_name = do
result <- runExceptT $ flip runSqlPool pool $ findProject project_name >>= \case
Nothing -> return Nothing
Just proj_id -> getProject proj_id
case result of
Left _ -> return Nothing
Right project_info -> return project_info
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 :: ConnectionPool -> String -> Handler ProjectsDepsolveResponse
projectsDepsolve pool project_names = do
let project_name_list = map T.pack (argify [project_names])
liftIO $ depsolveProjects pool project_name_list >>= \case
Left _ -> return $ ProjectsDepsolveResponse []
Right project_deps -> return $ ProjectsDepsolveResponse project_deps
depsolveProjects :: ConnectionPool -> [T.Text] -> IO (Either String [PackageNEVRA])
depsolveProjects pool project_name_list = do
result <- runExceptT $ flip runSqlPool pool $ do
formula <- depcloseNames ["x86_64"] project_name_list
solution <- solveCNF (formulaToCNF formula)
mapMaybeM groupIdToNevra $ map fst $ filter snd solution
case result of
Left e -> return $ Left (show e)
Right assignments -> return $ Right (map (mkPackageNEVRA . splitFilename) assignments)