-- Copyright (C) 2017 Red Hat, Inc.
--
-- This file is part of bdcs-api.
--
-- bdcs-api is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- bdcs-api is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with bdcs-api.  If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_HADDOCK ignore-exports, prune #-}

{-| API v0 routes
-}
module BDCS.API.V0(BuildInfo(..),
               ComposeBody(..),
               ComposeDeleteResponse(..),
               ComposeFailedResponse(..),
               ComposeFinishedResponse(..),
               ComposeInfoResponse(..),
               ComposeQueueResponse(..),
               ComposeResponse(..),
               ComposeStatusResponse(..),
               ComposeType(..),
               ComposeTypesResponse(..),
               Metadata(..),
               ModuleName(..),
               ModulesListResponse(..),
               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(..), queueStatusEnded, queueStatusText)
import           BDCS.API.Recipe
import           BDCS.API.Recipes
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 Codec.Archive.Tar as Tar
import qualified Control.Concurrent.ReadWriteLock as RWL
import           Control.Concurrent.STM.TChan(writeTChan)
import           Control.Concurrent.STM.TMVar(newEmptyTMVar, readTMVar)
import qualified Control.Exception.Safe as CES
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)


{-# ANN module ("HLint: ignore Eta reduce"  :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

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)]

-- Given a list of UUIDs, run mkComposeStatus on all of them and return only the results that
-- did not have any errors (like, from file IO).
filterMapComposeStatus :: MonadIO m => FilePath -> [T.Text] -> m [ComposeStatus]
filterMapComposeStatus dir lst = rights <$> mapM (liftIO . runExceptT . mkComposeStatus dir) lst

-- These are the API routes. This is not documented in haddock because it doesn't format it correctly
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
        :<|> "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)

-- | Connect the V0API type to all of the handlers
v0ApiServer :: ServerConfig -> Server V0API
v0ApiServer cfg = projectsListH
             :<|> projectsInfoH
             :<|> projectsDepsolveH
             :<|> recipesListH
             :<|> recipesInfoH
             :<|> recipesChangesH
             :<|> recipesNewH
             :<|> recipesDeleteH
             :<|> recipesUndoH
             :<|> recipesWorkspaceH
             :<|> recipesWorkspaceDeleteH
             :<|> recipesTagH
             :<|> recipesDiffH
             :<|> recipesDepsolveH
             :<|> recipesFreezeH
             :<|> modulesListH
             :<|> modulesListFilteredH
             :<|> composeH
             :<|> composeTypesH
             :<|> composeQueueH
             :<|> composeFinishedH
             :<|> composeFailedH
             :<|> composeStatusH
             :<|> composeInfoH
             :<|> composeCancelH
             :<|> composeDeleteH
             :<|> composeLogsH
             :<|> composeImageH
  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
    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)

-- | The JSON response for /blueprints/list
data RecipesListResponse = RecipesListResponse {
    rlrRecipes  :: [T.Text],                                    -- ^ List of blueprint names
    rlrOffset   :: Int,                                         -- ^ Pagination offset into results
    rlrLimit    :: Int,                                         -- ^ Pagination limit of results
    rlrTotal    :: Int                                          -- ^ Total number of blueprint names
} 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

-- | /api/v0/blueprints/list
-- List the names of the available blueprints
--
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
--
-- >  {
-- >      "blueprints": [
-- >          "development",
-- >          "glusterfs",
-- >          "http-server",
-- >          "jboss",
-- >          "kubernetes",
-- >          "octave",
-- >      ],
-- >      "offset": 0,
-- >      "limit": 20,
-- >      "total": 6
-- >  }
recipesList :: ServerConfig -> Maybe String -> Maybe Int -> Maybe Int -> Handler RecipesListResponse
recipesList ServerConfig{..} mbranch moffset mlimit = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do
    -- TODO Figure out how to catch GitError and throw a ServantErr
    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
    -- handleGitErrors :: GitError -> ServantErr
    -- handleGitErrors e = createAPIError err500 false ["recipes_list: Git Error: " ++ show e]

    -- | Return the offset or the default
    offset :: Int
    offset = fromMaybe 0 moffset

    -- | Return the limit or the default
    limit :: Int
    limit  = fromMaybe 20 mlimit


-- | Status of a blueprint's workspace
data WorkspaceChanges = WorkspaceChanges {
    wcName      :: T.Text,                                              -- ^ Blueprint name
    wcChanged   :: Bool                                                 -- ^ True when it is newer than the last commit
} 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{..}


-- | The JSON response for /blueprints/info
data RecipesInfoResponse = RecipesInfoResponse {
    rirChanges  :: [WorkspaceChanges],                                  -- ^ Workspace status for each blueprint
    rirRecipes  :: [Recipe],                                            -- ^ The Recipe record
    rirErrors   :: [String]                                             -- ^ Errors reading the blueprint
} 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{..}


-- | /api/v0/blueprints/info/\<recipes\>
-- Return the contents of the blueprint, or a list of recipes
--
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
-- [@recipes_names@]: A comma separated list of blueprint names
--
-- The errors list may be empty, or may include blueprint-specific errors if
-- there was a problem retrieving it.
--
-- > {
-- >     "changes": [
-- >         {
-- >             "name": "blueprint-test",
-- >             "changed": true
-- >         },
-- >     ],
-- >     "blueprints": [
-- >         {
-- >             "name": "http-server",
-- >             "description": "An example http server with PHP and MySQL support.",
-- >             "version": "0.0.1",
-- >             "modules": [
-- >                 {
-- >                     "name": "httpd",
-- >                     "version": "2.4.*"
-- >                 },
-- >                 {
-- >                     "name": "mod_auth_kerb",
-- >                     "version": "5.4"
-- >                 },
-- >                 {
-- >                     "name": "mod_ssl",
-- >                     "version": "2.4.*"
-- >                 },
-- >                 {
-- >                     "name": "php",
-- >                     "version": "5.4.*"
-- >                 },
-- >                 {
-- >                     "name": "php-mysql",
-- >                     "version": "5.4.*"
-- >                 }
-- >             ],
-- >             "packages": [
-- >                 {
-- >                     "name": "tmux",
-- >                     "version": "2.2"
-- >                 },
-- >                 {
-- >                     "name": "openssh-server",
-- >                     "version": "6.6.*"
-- >                 },
-- >                 {
-- >                     "name": "rsync",
-- >                     "version": "3.0.*"
-- >                 }
-- >             ]
-- >         },
-- >     "errors": ["a-missing-blueprint: Error retrieving a-missing-blueprint.toml"]
-- > }
--
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

-- | Get the recipe from the workspace or from git
-- If there is neither workspace or git recipes then an error is returned.
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
    --   read the workspace recipe if it exists, errors are mapped to Nothing
    ws_recipe <- catch_ws_recipe
    --   read the git recipe (if it exists), Errors are mapped to Left
    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

    -- | Read the recipe from the workspace, and convert WorkspaceErrors into Nothing
    catch_ws_recipe :: IO (Maybe Recipe)
    catch_ws_recipe =
        CES.catch (workspaceRead (gitRepo repoLock) branch recipe_name)
                  (\(_ :: WorkspaceError) -> return Nothing)

    -- | Read the recipe from git, and convert errors into Left descriptions of what went wrong.
    catch_git_recipe :: IO (Either String (T.Text, Recipe))
    catch_git_recipe =
        CES.catches (readRecipeCommit (gitRepo repoLock) branch recipe_name Nothing)
                    [CES.Handler (\(e :: GitError) -> return $ Left (show e)),
                     CES.Handler (\(e :: GError) -> return $ Left (show e))]


-- | Details about commits to a blueprint
data RecipeChanges = RecipeChanges {
    rcName      :: T.Text,                                              -- ^ Blueprint name
    rcChange    :: [CommitDetails],                                     -- ^ Details of the commit
    rcTotal     :: Int                                                  -- ^ Total number of commits
} 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{..}


-- The JSON response for /blueprints/changes
data RecipesChangesResponse = RecipesChangesResponse {
    rcrRecipes  :: [RecipeChanges],                                     -- ^ Changes for each blueprint
    rcrErrors   :: [String],                                            -- ^ Any errors for the requested changes
    rcrOffset   :: Int,                                                 -- ^ Pagination offset
    rcrLimit    :: Int                                                  -- ^ Pagination limit
} 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{..}


-- | /api/v0/blueprints/changes/\<recipes\>
-- Return the commit history of the blueprints
--
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
-- [@recipes_name@]: The blueprint name
-- [@moffset@]: The offset from the start of the results. Defaults to 0
-- [@mlimit@]: Limit to the number of results to be returned. Defaults to 20
--
-- The changes for each listed blueprint will have offset and limit applied to them.
-- This means that there will be cases where changes will be empty, when offset > total
-- for the blueprint.
--
-- If a blueprint commit has been tagged as a new revision the changes will include a
-- `revision` field set to the revision number. If the commit has not been tagged it
-- will not have this field included.
--
-- > {
-- >     "blueprints": [
-- >         {
-- >             "name": "nfs-server",
-- >             "changes": [
-- >                 {
-- >                     "commit": "97d483e8dd0b178efca9a805e5fd8e722c48ac8e",
-- >                     "time": "Wed,  1 Mar 2017 13:29:37 -0800",
-- >                     "summary": "Recipe nfs-server saved"
-- >                 },
-- >                 {
-- >                     "commit": "857e1740f983bf033345c3242204af0ed7b81f37",
-- >                     "time": "Wed,  1 Mar 2017 09:28:53 -0800",
-- >                     "summary": "Recipe nfs-server saved",
-- >                     "revision" : 1
-- >                 }
-- >             ],
-- >             "total": 2
-- >         },
-- >         {
-- >             "name": "ruby",
-- >             "changes": [
-- >                 {
-- >                     "commit": "4b84f072befc3f4debbe1348d6f4b166f7c83d78",
-- >                     "time": "Wed,  1 Mar 2017 13:32:09 -0800",
-- >                     "summary": "Recipe ruby saved"
-- >                 },
-- >                 {
-- >                     "commit": "85999253c1790367a860a344ea622971b7e0a050",
-- >                     "time": "Wed,  1 Mar 2017 13:31:19 -0800",
-- >                     "summary": "Recipe ruby saved"
-- >                 }
-- >             ],
-- >             "total": 2
-- >         }
-- >     ],
-- >     "errors": ["a-missing-recipe: Error retrieving a-missing-blueprint.toml"]
-- >     "offset": 0,
-- >     "limit": 20
-- > }
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 =
        CES.catches (Right <$> listRecipeCommits (gitRepo cfgRepoLock) (defaultBranch mbranch) recipe_name)
                    [CES.Handler (\(e :: GitError) -> return $ Left (show e)),
                     CES.Handler (\(e :: GError) -> return $ Left (show e))]


-- | POST /api/v0/blueprints/new
-- Create or update a blueprint.
--
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
-- [@recipe@]: The blueprint record
--
-- The body of the post is a JSON or TOML representation of the blueprint. If Conten-Type is application/json
-- it uses the same format received from /api/v0/blueprints/info/\<blueprints\>, and if it is text/x-toml it uses
-- the blueprint's TOML format for the body.
--
-- The response for a successful POST is:
--
-- > {
-- >     "status": true,
-- >     "errors": []
-- > }
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 =
        CES.catches (Right <$> commitRecipe (gitRepo cfgRepoLock) (defaultBranch mbranch) recipe)
                    [CES.Handler (\(e :: GitError) -> return $ Left (show e)),
                     CES.Handler (\(e :: GError) -> return $ Left (show e))]


-- | DELETE /api/v0/blueprints/delete/\<recipe\>
-- Delete the named blueprint from the repository branch
--
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
-- [@recipe_name@]: The blueprint name
--
-- The response for a successful DELETE is:
--
-- > {
-- >     "status": true,
-- >     "errors": []
-- > }
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 =
        CES.catches (Right <$> deleteRecipe (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name))
                    [CES.Handler (\(e :: GitError) -> return $ Left (show e)),
                     CES.Handler (\(e :: GError) -> return $ Left (show e))]


-- | POST /api/v0/blueprints/undo/\<recipe\>/\<commit\>
-- Revert a blueprint to a previous commit
--
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
-- [@recipe_name@]: The blueprint name
-- [@commit@]: The commit to revert to
--
-- The response for a successful POST is:
--
-- > {
-- >     "status": true,
-- >     "errors": []
-- > }
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 =
        CES.catches (Right <$> revertRecipe (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name) (T.pack commit))
                    [CES.Handler (\(e :: GitError) -> return $ Left (show e)),
                     CES.Handler (\(e :: GError) -> return $ Left (show e))]


-- | POST /api/v0/blueprints/workspace
-- Update the temporary blueprint workspace
--
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
-- [@recipe@]: The blueprint record
--
-- The body of the post is the same as /blueprints/new/. For more details on the
-- workspace see "BDCS.API.Workspace"
--
-- The response for a successful POST is:
--
-- > {
-- >     "status": true,
-- >     "errors": []
-- > }
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 =
        CES.catches (Right <$> workspaceWrite (gitRepo cfgRepoLock) (defaultBranch mbranch) recipe)
                    [CES.Handler (\(e :: GitError) -> return $ Left (show e)),
                     CES.Handler (\(e :: GError) -> return $ Left (show e))]


-- | DELETE /api/v0/blueprints/workspace/\<recipe\>
-- Delete the named blueprint from the workspace
--
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
-- [@recipe_name@]: The blueprint name
--
-- The response for a successful DELETE is:
--
-- > {
-- >     "status": true,
-- >     "errors": []
-- > }
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 =
        CES.catches (Right <$> workspaceDelete (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name))
                    [CES.Handler (\(e :: GitError) -> return $ Left (show e)),
                     CES.Handler (\(e :: GError) -> return $ Left (show e))]


-- | POST /api/v0/blueprints/tag/<blueprint>
-- Tag the most recent blueprint commit as the next revision
--
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
-- [@recipe_name@]: The blueprint name
--
-- If the commit is already tagged it will return False.
--
-- The response for a successful POST is:
--
-- > {
-- >     "status": true,
-- >     "errors": []
-- > }
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 =
        CES.catches (Right <$> tagRecipeCommit (gitRepo cfgRepoLock) (defaultBranch mbranch) (T.pack recipe_name))
                    [CES.Handler (\(e :: GitError) -> return $ Left (show e)),
                     CES.Handler (\(e :: GError) -> return $ Left (show e))]


-- | JSON response for /blueprints/diff
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{..}

-- | /api/v0/blueprints/diff/<blueprint>/<from_commit>/<to_commit>
-- Return the diff between the two blueprint commits.
--
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
-- [@recipe_name@]: The blueprint name
-- [@from_commit@]: The older commit to caclulate the difference from, can also be NEWEST
-- [@to_commit@]: The newer commit to calculate the diff. to, can also be NEWEST or WORKSPACE
--
-- If there is an error retrieving a commit (eg. it cannot find the hash), it will use HEAD
-- instead and log an error.
--
--
-- In addition to the commit hashes listed by a call to /blueprints/changes/\<blueprint-name\> you
-- can use NEWEST to compare the latest commit, and WORKSPACE to compare it with
-- the current temporary workspace version of the blueprint. eg. to see what the differences
-- are between the current workspace and most recent commit of http-server you would call:
--
-- > /blueprints/diff/http-server/NEWEST/WORKSPACE
--
-- Each entry in the response's diff object contains the old blueprint value and the new one.
-- If old is null and new is set, then it was added.
-- If new is null and old is set, then it was removed.
-- If both are set, then it was changed.
--
-- The old/new entries will have the name of the blueprint field that was changed. This
-- can be one of: Name, Description, Version, Module, or Package.
-- The contents for these will be the old/new values for them.
--
-- In the example below the description and version were changed. The php module's
-- version was changed, the rsync package was removed, and the vim-enhanced package
-- was added.
--
-- # Examples
--
-- > {
-- >     "diff": [
-- >         {
-- >             "old": {
-- >                 "Description": "An example http server with PHP and MySQL support."
-- >             },
-- >             "new": {
-- >                 "Description": "Apache HTTP Server"
-- >             }
-- >         },
-- >         {
-- >             "old": {
-- >                 "Version": "0.0.1"
-- >             },
-- >             "new": {
-- >                 "Version": "0.1.1"
-- >             }
-- >         },
-- >         {
-- >             "old": {
-- >                 "Module": {
-- >                     "name": "php",
-- >                     "version": "5.4.*"
-- >                 }
-- >             },
-- >             "new": {
-- >                 "Module": {
-- >                     "name": "php",
-- >                     "version": "5.6.*"
-- >                 }
-- >             }
-- >         },
-- >         {
-- >             "old": null,
-- >             "new": {
-- >                 "Package": {
-- >                     "name": "vim-enhanced",
-- >                     "version": "8.0.*"
-- >                 }
-- >             }
-- >         },
-- >         {
-- >             "old": {
-- >                 "Package": {
-- >                     "name": "rsync",
-- >                     "version": "3.0.*"
-- >                 }
-- >             },
-- >             "new": null
-- >         }
-- >     ]
-- > }
recipesDiff :: ServerConfig -> Maybe String -> String -> String -> String -> Handler RecipesDiffResponse
recipesDiff ServerConfig{..} mbranch recipe_name from_commit to_commit = liftIO $ RWL.withRead (gitRepoLock cfgRepoLock) $ do
    -- Setup old_recipe
    -- NEWEST == read the latest git commit for recipe_name
    -- Otherwise try to read the passed-in commit hash string
    old_recipe <- get_recipe from_commit

    -- Setup new_recipe
    -- WORKSPACE == read the recipe's workspace
    -- NEWEST == read the latest git commit for recipe_name
    -- Otherwise try to read the passed-in commit hash string
    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)
        -- If there is no workspace recipe fall back to most recent commit
        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)

    -- | Read the recipe from the workspace, and convert WorkspaceErrors into Nothing
    catch_ws_recipe :: T.Text -> IO (Maybe Recipe)
    catch_ws_recipe name =
        CES.catch (workspaceRead (gitRepo cfgRepoLock) (defaultBranch mbranch) name)
                  (\(_ :: WorkspaceError) -> return Nothing)

    -- | Read the recipe from git, and convert errors into Left descriptions of what went wrong.
    catch_git_recipe :: T.Text -> Maybe T.Text -> IO (Either String (T.Text, Recipe))
    catch_git_recipe name commit =
        CES.catches (readRecipeCommit (gitRepo cfgRepoLock) (defaultBranch mbranch) name commit)
                    [CES.Handler (\(e :: GitError) -> return $ Left (show e)),
                     CES.Handler (\(e :: GError) -> return $ Left (show e))]


-- | The blueprint's dependency details
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{..}


-- | The JSON response for /blueprints/depsolve/<blueprints>
data RecipesDepsolveResponse = RecipesDepsolveResponse {
    rdrRecipes  :: [RecipeDependencies],                             -- ^ List of blueprints and their dependencies
    rdrErrors   :: [String]                                          -- ^ Errors reading the blueprint
} 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{..}

-- | /api/v0/blueprints/depsolve/<blueprints>
-- Return the blueprint and summary information about all of its modules and packages.
--
-- [@pool@]: The sqlite connection pool object
-- [@repoLock@]: The git repositories `ReadWriteLock` and Repository object
-- [@mbranch@]: The branch name
-- [@recipe_names@]: The blueprint names to depsolve, comma-separated if there is more than one
--
-- If a workspace version of the blueprint is found it will be used for the depsolve. If there are
-- any errors reading the blueprint, or depsolving it, they will be returned in the 'errors' object.
--
-- # Error example
--
-- > {
-- >     "errors": ["nfs-server.toml is not present on branch master"],
-- >     "blueprints": []
-- > }
--
--
-- A successful result will include 3 items. 'dependencies' will be the NEVRAs of all of the
-- projects needed to satisfy the blueprint's dependencies. 'modules' will be the project NEVRAs
-- for the modules and packages explicitly listed in the blueprint, and 'blueprint' will be a copy of
-- the blueprint that was depsolved.
--
-- # Abbreviated successful example
--
-- > {
-- >     "errors": [],
-- >     "blueprints": [
-- >         {
-- >             "dependencies": [
-- >                 {
-- >                     "arch": "x86_64",
-- >                     "epoch": 0,
-- >                     "name": "apr",
-- >                     "release": "3.el7",
-- >                     "version": "1.4.8"
-- >                 },
-- >                 {
-- >                     "arch": "x86_64",
-- >                     "epoch": 0,
-- >                     "name": "apr-util",
-- >                     "release": "6.el7",
-- >                     "version": "1.5.2"
-- >                 },
-- >                 ...
-- >             ],
-- >             "modules": [
-- >                 {
-- >                     "arch": "x86_64",
-- >                     "epoch": 0,
-- >                     "name": "httpd",
-- >                     "release": "67.el7",
-- >                     "version": "2.4.6"
-- >                 },
-- >                 {
-- >                     "arch": "x86_64",
-- >                     "epoch": 0,
-- >                     "name": "mod_auth_kerb",
-- >                     "release": "28.el7",
-- >                     "version": "5.4"
-- >                 },
-- >                 ...
-- >             ],
-- >            "blueprint": {
-- >                 "description": "An example http server with PHP and MySQL support.",
-- >                 "modules": [
-- >                     {
-- >                         "name": "httpd",
-- >                         "version": "2.4.*"
-- >                     },
-- >                     {
-- >                         "name": "mod_auth_kerb",
-- >                         "version": "5.4"
-- >                     },
-- >                     {
-- >                         "name": "mod_ssl",
-- >                         "version": "2.4.*"
-- >                     },
-- >                     {
-- >                         "name": "php",
-- >                         "version": "5.4.*"
-- >                     },
-- >                     {
-- >                         "name": "php-mysql",
-- >                         "version": "5.4.*"
-- >                     }
-- >                 ],
-- >                 "name": "http-server",
-- >                 "packages": [
-- >                     {
-- >                         "name": "tmux",
-- >                         "version": "2.2"
-- >                     },
-- >                     {
-- >                         "name": "openssh-server",
-- >                         "version": "6.6.*"
-- >                     },
-- >                     {
-- >                         "name": "rsync",
-- >                         "version": "3.0.*"
-- >                     }
-- >                 ],
-- >                 "version": "0.2.0"
-- >             }
-- >         }
-- >     ]
-- > }
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
        -- Convert the list of names into a list of Recipes.  Also collect a list of errors
        -- that occurred while doing the conversion.  We don't simply stop on the first error.
        results <- mapM (getOneRecipeInfo cfgRepoLock (defaultBranch mbranch)) recipeNames
        let (errors, recipes) = partitionEithers results

        -- Depsolve each recipe, also gathering up any errors from this process as well.  Because
        -- depsolveRecipe lives elsewhere and therefore cannot return types defined in this file,
        -- it returns more generic things lacking the recipe name.  Thus, here we must convert
        -- both possibilities of the return type.
        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


-- | The JSON response for /blueprints/freeze/<blueprints>
data RecipesFreezeResponse = RecipesFreezeResponse {
    rfrRecipes  :: [Recipe],                                         -- ^ Recipes with exact versions
    rfrErrors   :: [String]                                          -- ^ Errors reading the blueprint
} 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{..}

-- | /api/v0/blueprints/freeze/<blueprints>
-- Return the contents of the blueprint with frozen dependencies instead of expressions.
--
-- This depsolves the blueprint, and then replaces the modules and packages versions with
-- the EVR found by the depsolve, returning a frozen blueprint.
--
-- # Examples
--
-- > {
-- >     "errors": [],
-- >     "blueprints": [
-- >         {
-- >             "description": "An example http server with PHP and MySQL support.",
-- >             "modules": [
-- >                 {
-- >                     "name": "httpd",
-- >                     "version": "2.4.6-67.el7"
-- >                 },
-- >                 {
-- >                     "name": "mod_auth_kerb",
-- >                     "version": "5.4-28.el7"
-- >                 },
-- >                 {
-- >                     "name": "mod_ssl",
-- >                     "version": "1:2.4.6-67.el7"
-- >                 },
-- >                 {
-- >                     "name": "php",
-- >                     "version": "5.4.16-42.el7"
-- >                 },
-- >                 {
-- >                     "name": "php-mysql",
-- >                     "version": "5.4.16-42.el7"
-- >                 }
-- >             ],
-- >             "name": "http-server",
-- >             "packages": [
-- >                 {
-- >                     "name": "tmux",
-- >                     "version": "1.8-4.el7"
-- >                 },
-- >                 {
-- >                     "name": "openssh-server",
-- >                     "version": "7.4p1-11.el7"
-- >                 },
-- >                 {
-- >                     "name": "rsync",
-- >                     "version": "3.0.9-18.el7"
-- >                 }
-- >             ],
-- >             "version": "0.2.0"
-- >         }
-- >     ]
-- > }
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
        -- Convert the list of names into a list of Recipes.  Also collect a list of errors
        -- that occurred while doing the conversion.  We don't simply stop on the first error.
        results <- mapM (getOneRecipeInfo cfgRepoLock (defaultBranch mbranch)) recipeNames
        let (errors, recipes) = partitionEithers results

        -- Depsolve each recipe, also gathering up any errors from this process as well.  Because
        -- depsolveRecipe lives elsewhere and therefore cannot return types defined in this file,
        -- it returns more generic things lacking the recipe name.  Thus, here we must convert
        -- both possibilities of the return type.
        --
        -- Additionally, here we must replace everything with the frozen version numbers.
        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

    -- Replace the recipe's module and package versions with the EVR selected by depsolving
    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 }

    -- Get a frozen list of projects using the depsolved NEVRAs
    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)

    -- Lookup a RecipeModule in the list of depsolved packages
    lookupRecipeModule :: RecipeModule -> [PackageNEVRA] -> Maybe PackageNEVRA
    lookupRecipeModule recipe_module all_nevras = find (\e -> pnName e == T.pack (rmName recipe_module)) all_nevras

    -- Create a new RecipeModule with frozen version
    frozenRecipeModule :: RecipeModule -> PackageNEVRA -> RecipeModule
    frozenRecipeModule rm pn = rm { rmVersion = getVersionFromNEVRA pn }

    -- Convert a PackageNEVRA to a string for RecipeModule
    -- eg. 2:3.1.4-22.fc27
    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` ":"

-- | The JSON response for /projects/list
data ProjectsListResponse = ProjectsListResponse {
    plpProjects :: [Projects],                                  -- ^ List of project names
    plpOffset   :: Int,                                         -- ^ Pagination offset into results
    plpLimit    :: Int,                                         -- ^ Pagination limit of results
    plpTotal    :: Int                                          -- ^ Total number of project names
} 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{..}

-- | /api/v0/projects/list
-- Return the list of available projects
--
-- # Example
--
-- > {
-- >     "limit": 20,
-- >     "offset": 0,
-- >     "projects": [
-- >         {
-- >             "description": "389 Directory Server is an LDAPv3 compliant server. ...",
-- >             "homepage": "https://www.port389.org/",
-- >             "name": "389-ds-base",
-- >             "summary": "389 Directory Server (base)",
-- >             "upstream_vcs": "UPSTREAM_VCS"
-- >         },
-- >         }
-- >     ],
-- >     "total": 2117
-- > }
projectsList :: ServerConfig -> Maybe Int -> Maybe Int -> Handler ProjectsListResponse
projectsList ServerConfig{..} moffset mlimit = do
    result <- runExceptT $ runSqlPool (getProjectsLike offset64 limit64 "%") cfgPool
    case result of
        -- TODO Properly report errors with a different response
        Left _                        -> return $ ProjectsListResponse [] offset limit 0
        Right (project_info, total64) -> return $ ProjectsListResponse project_info offset limit (fromIntegral total64)
  where
    -- | Return the offset or the default
    offset :: Int
    offset = fromMaybe 0 moffset

    -- | Return the limit or the default
    limit :: Int
    limit  = fromMaybe 20 mlimit

    -- | Return the offset or the default
    offset64 :: Maybe Int64
    offset64 = Just $ fromIntegral $ fromMaybe 0 moffset

    -- | Return the limit or the default
    limit64 :: Maybe Int64
    limit64  = Just $ fromIntegral $ fromMaybe 20 mlimit


-- | The JSON response for /projects/info
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"

-- | /api/v0/projects/info/<projects>
-- Return information about the comma-separated list of projects
--
-- # Example
--
-- > {
-- >   "projects": [
-- >     {
-- >       "builds": [
-- >         {
-- >           "arch": "x86_64",
-- >           "build_config_ref": "BUILD_CONFIG_REF",
-- >           "build_env_ref": "BUILD_ENV_REF",
-- >           "build_time": "2017-03-01T08:39:23",
-- >           "changelog": "- restore incremental backups correctly, files ...",
-- >           "epoch": "2",
-- >           "metadata": {},
-- >           "release": "32.el7",
-- >           "source": {
-- >             "license": "GPLv3+",
-- >             "metadata": {},
-- >             "source_ref": "SOURCE_REF",
-- >             "version": "1.26"
-- >           }
-- >         }
-- >       ],
-- >       "description": "The GNU tar program saves many files ...",
-- >       "homepage": "http://www.gnu.org/software/tar/",
-- >       "name": "tar",
-- >       "summary": "A GNU file archiving program",
-- >       "upstream_vcs": "UPSTREAM_VCS"
-- >     }
-- >   ]
-- > }
-- >
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

-- | The JSON response for /projects/depsolve/<projects>
data ProjectsDepsolveResponse = ProjectsDepsolveResponse {
    pdrProjects  :: [PackageNEVRA]                                      -- ^List of dependencies
} 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{..}

-- | /api/v0/projects/depsolve/<projects>
-- Return the dependencies of a comma separated list of projects
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


-- | Information about a module
data ModuleName = ModuleName {
    mnName      :: T.Text,                                       -- ^ Module name
    mnGroupType :: T.Text                                        -- ^ Group type (always "rpm" for now)
} 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{..}

-- | Make a ModuleName from a string
mkModuleName :: T.Text -> ModuleName
mkModuleName name = ModuleName { mnName=name, mnGroupType="rpm" }


-- | The JSON response for /modules/list
data ModulesListResponse = ModulesListResponse {
    mlrModules  :: [ModuleName],                                -- ^ List of modules
    mlrOffset   :: Int,                                         -- ^ Pagination offset into results
    mlrLimit    :: Int,                                         -- ^ Pagination limit of results
    mlrTotal    :: Int                                          -- ^ Total number of module names
} 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{..}

-- | /api/v0/modules/list
-- /api/v0/modules/list/<module_names>
-- Return a list of all of the available modules, filtering by module_names (a comma-separated
-- list).  This includes the name and the group_type, which is currently always "rpm".
--
-- >  {
-- >      "modules": [
-- >        {
-- >          "group_type": "rpm",
-- >          "name": "0ad"
-- >        },
-- >        {
-- >          "group_type": "rpm",
-- >          "name": "0ad-data"
-- >        },
-- >        ....
-- >      ],
-- >      "offset": 0,
-- >      "limit": 20,
-- >      "total": 6
-- >  }
modulesList :: ServerConfig -> Maybe Int -> Maybe Int -> String -> Handler ModulesListResponse

-- | Special case for listing all the modules
-- Uses SQL offset, limit, and case-insensitive sorting
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
    -- | Return the offset or the default
    offset :: Int
    offset = fromMaybe 0 moffset

    -- | Return the limit or the default
    limit :: Int
    limit  = fromMaybe 20 mlimit

    -- | Return the offset or the default
    offset64 :: Maybe Int64
    offset64 = Just $ fromIntegral $ fromMaybe 0 moffset

    -- | Return the limit or the default
    limit64 :: Maybe Int64
    limit64  = Just $ fromIntegral $ fromMaybe 20 mlimit

modulesList ServerConfig{..} moffset mlimit module_names = do
    -- Substitute % for * in the module_names
    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
    -- | Return the offset or the default
    offset :: Int
    offset = fromMaybe 0 moffset

    -- | Return the limit or the default
    limit :: Int
    limit  = fromMaybe 20 mlimit

data ComposeBody = ComposeBody {
    cbName :: T.Text,                                                   -- ^ Recipe name (from /blueprints/list)
    cbType :: T.Text,                                                   -- ^ Compose type (from /compose/types)
    cbBranch :: Maybe T.Text                                            -- ^ The git branch to use for this blueprint
} 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{..}

-- | JSON status response
data ComposeResponse = ComposeResponse {
    crStatus  :: Bool,                                                  -- ^ Success/Failure of the request
    crBuildID :: T.Text                                                 -- ^ UUID of the in-progress build
} 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{..}

-- | POST /api/v0/compose
-- Start a compose.
-- TODO implement test support
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)
            -- Write out the original recipe.
            TIO.writeFile (resultsDir </> "blueprint.toml") (recipeTOML recipe)
            -- Write out the compose details
            TIO.writeFile (resultsDir </> "compose.toml") (composeConfigTOML $ ComposeConfig commit_id ty)

        -- Freeze the recipe so we have precise versions of its components.  This could potentially
        -- return multiple frozen recipes, but I think only if we asked it to do multiple things.
        -- We did not, so we can safely assume there's only one result.
        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
    -- | Construct an error message for unsupported output selected
    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

-- | The JSON response for /compose/types
data ComposeType = ComposeType {
    ctEnabled :: Bool,                      -- ^ Is this output type enabled?
    ctName    :: T.Text                     -- ^ The name of the output type
} 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{..}


-- | /api/v0/compose/types
--
-- Returns the list of supported output types that are valid for use with 'POST /api/v0/compose'
--
-- > {
-- >   "types": [
-- >     {
-- >       "enabled": true,
-- >       "name": "tar"
-- >     }
-- >   ]
-- > }
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"

-- | /api/v0/compose/queue
--
-- Return the status of the build queue. It includes information about the builds waiting,
-- and the build that is running.
--
-- > {
-- >   "new": [
-- >     {
-- >       "id": "45502a6d-06e8-48a5-a215-2b4174b3614b",
-- >       "recipe": "glusterfs",
-- >       "queue_status": "WAITING",
-- >       "timestamp": 1517362647.4570868,
-- >       "version": "0.0.6"
-- >     },
-- >     {
-- >       "id": "6d292bd0-bec7-4825-8d7d-41ef9c3e4b73",
-- >       "recipe": "kubernetes",
-- >       "queue_status": "WAITING",
-- >       "timestamp": 1517362659.0034983,
-- >       "version": "0.0.1"
-- >     }
-- >   ],
-- >   "run": [
-- >     {
-- >       "id": "745712b2-96db-44c0-8014-fe925c35e795",
-- >       "recipe": "glusterfs",
-- >       "queue_status": "RUNNING",
-- >       "timestamp": 1517362633.7965999,
-- >       "version": "0.0.6"
-- >     }
-- >   ]
-- > }
composeQueue :: ServerConfig -> Handler ComposeQueueResponse
composeQueue ServerConfig{..} = do
    -- Construct a new message to ask what composes are currently waiting.
    -- Each message includes an initially empty TMVar where the response
    -- will be written.  This prevents needing to write a communications
    -- protocol.  Making it initially empty is very important.
    r <- liftIO $ atomically newEmptyTMVar
    liftIO $ atomically $ writeTChan cfgChan (AskBuildsWaiting, Just r)

    -- Wait for the response to show up in the TMVar we created.  This blocks,
    -- but the server doesn't do much in its main thread so it shouldn't block
    -- for long.
    buildsWaiting <- liftIO (atomically $ readTMVar r) >>= \case
        RespBuildsWaiting lst -> return lst
        _                     -> return []

    -- And then we do the same thing for builds currently running.
    r' <- liftIO $ atomically newEmptyTMVar
    liftIO $ atomically $ writeTChan cfgChan (AskBuildsInProgress, Just r')
    buildsRunning <- liftIO (atomically $ readTMVar r') >>= \case
        RespBuildsInProgress lst -> return lst
        _                        -> return []

    -- Finally we can create a response to send back to the client.
    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"

-- | /api/v0/compose/finished
--
-- Return the details on all of the finished composes on the system.
--
-- > {
-- >   "finished": [
-- >     {
-- >       "id": "70b84195-9817-4b8a-af92-45e380f39894",
-- >       "recipe": "glusterfs",
-- >       "queue_status": "FINISHED",
-- >       "timestamp": 1517351003.8210032,
-- >       "version": "0.0.6"
-- >     },
-- >     {
-- >       "id": "e695affd-397f-4af9-9022-add2636e7459",
-- >       "recipe": "glusterfs",
-- >       "queue_status": "FINISHED",
-- >       "timestamp": 1517362289.7193348,
-- >       "version": "0.0.6"
-- >     }
-- >   ]
-- > }
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"

-- | /api/v0/compose/failed
--
-- Return the details on all of the failed composes on the system.
--
-- > {
-- >   "failed": [
-- >     {
-- >       "id": "8c8435ef-d6bd-4c68-9bf1-a2ef832e6b1a",
-- >       "recipe": "http-server",
-- >       "queue_status": "FAILED",
-- >       "timestamp": 1517523249.9301329,
-- >       "version": "0.0.2"
-- >     }
-- >   ]
-- > }
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"

-- | /api/v0/compose/status/<uuids>
--
-- Return the details for each of the comma-separated list of uuids.
--
-- > {
-- >   "uuids": [
-- >     {
-- >       "id": "8c8435ef-d6bd-4c68-9bf1-a2ef832e6b1a",
-- >       "recipe": "http-server",
-- >       "queue_status": "FINISHED",
-- >       "timestamp": 1517523644.2384307,
-- >       "version": "0.0.2"
-- >     },
-- >     {
-- >       "id": "45502a6d-06e8-48a5-a215-2b4174b3614b",
-- >       "recipe": "glusterfs",
-- >       "queue_status": "FINISHED",
-- >       "timestamp": 1517363442.188399,
-- >       "version": "0.0.6"
-- >     }
-- >   ]
-- > }
composeStatus :: ServerConfig -> [T.Text] -> Handler ComposeStatusResponse
composeStatus ServerConfig{..} uuids =
    ComposeStatusResponse <$> filterMapComposeStatus cfgResultsDir uuids


data ComposeInfoResponse = ComposeInfoResponse {
    cirCommit      :: T.Text,                                           -- ^ Blueprint git commit hash
    cirBlueprint   :: Recipe,                                           -- ^ Frozen Blueprint
    cirType        :: ExportType,                                       -- ^ Export type (tar, etc.)
    cirBuildId     :: T.Text,                                           -- ^ Build UUID
    cirQueueStatus :: T.Text                                            -- ^ Build queue status
} 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{..}

-- | /api/v0/compose/info/<uuid>
--
-- Get detailed information about the compose. The returned JSON string will
-- contain the following information:
--
--   * id - The uuid of the comoposition
--   * config - containing the configuration settings used to run Anaconda
--   * blueprint - The depsolved blueprint used to generate the kickstart
--   * commit - The (local) git commit hash for the blueprint used
--   * deps - The NEVRA of all of the dependencies used in the composition
--   * compose_type - The type of output generated (tar, iso, etc.)
--   * queue_status - The final status of the composition (FINISHED or FAILED)
--
-- Example::
--
-- > {
-- >   "commit": "7078e521a54b12eae31c3fd028680da7a0815a4d",
-- >   "compose_type": "tar",
-- >   "id": "c30b7d80-523b-4a23-ad52-61b799739ce8",
-- >   "queue_status": "FINISHED",
-- >   "blueprint": {
-- >     "description": "An example kubernetes master",
-- >     ...
-- >   }
-- > }
--
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"]

    -- Read the compose.toml ComposeConfig data from the results directory
    readComposeConfigFile :: FilePath -> ExceptT ServantErr IO ComposeConfig
    readComposeConfigFile dir = withExceptT (const config_error) $
        tryIO (TIO.readFile (dir </> "compose.toml")) >>= ExceptT . return . parseComposeConfig

    -- Read the frozen.toml blueprint from the results directory
    readFrozenBlueprintFile :: FilePath -> ExceptT ServantErr IO Recipe
    readFrozenBlueprintFile dir = withExceptT (const frozen_error) $
        tryIO (TIO.readFile (dir </> "compose.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"


-- | DELETE /api/v0/compose/cancel/<uuid>
--
-- Cancel the build, if it is not finished, and delete the results. It will return a
-- status of True if it is successful.
--
-- The response for a successful DELETE is:
--
-- > {
-- >     "status": true,
-- >     "errors": []
-- > }
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"]

-- | DELETE /api/v0/compose/delete/<uuids>
--
-- Delete the list of comma-separated uuids from the compose results.
--
-- > {
-- >   "errors": [],
-- >   "uuids": [
-- >     {
-- >       "status": true,
-- >       "uuid": "ae1bf7e3-7f16-4c9f-b36e-3726a1093fd0"
-- >     }
-- >   ]
-- > }
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 }


-- | /api/v0/compose/logs/<uuid>
--
-- Returns a .tar of the compose logs.  The tar is not compressed, but it is
-- not large.
--
-- The mime type is set to 'application/x-tar' and the filename is set to
-- UUID-logs.tar
composeLogs :: KnownSymbol h => ServerConfig -> String -> Handler (Headers '[Header h String] LBS.ByteString)
composeLogs ServerConfig{..} uuid = do
    result <- liftIO $ runExceptT $ mkComposeStatus cfgResultsDir (cs uuid)
    case result of
        Left _                  -> throwError $ createAPIError err400 False ["compose_logs: " ++ cs uuid ++ " is not a valid build uuid"]
        Right ComposeStatus{..} ->
            if not (queueStatusEnded csQueueStatus)
            then throwError $ createAPIError err400 False ["compose_logs: Build " ++ cs uuid ++ " not in FINISHED or FAILED state."]
            else do
                let composeResultsDir = cfgResultsDir </> cs uuid
                    logFiles          = ["compose.log"]

                tar <- liftIO $ Tar.pack composeResultsDir logFiles
                return $ addHeader ("attachment; filename=" ++ uuid ++ "-logs.tar;") (Tar.write tar)


-- | /api/v0/compose/image/<uuid>
--
-- Returns the output image from the build. The filename is set to the filename
-- from the build with the UUID as a prefix. eg. UUID-root.tar.xz or UUID-boot.iso.
composeImage :: KnownSymbol h => ServerConfig -> T.Text -> Handler (Headers '[Header h String] LBS.ByteString)
composeImage ServerConfig{..} uuid = do
    result <- liftIO $ runExceptT $ mkComposeStatus cfgResultsDir (cs uuid)
    case result of
        Left _                  -> throwError $ createAPIError err400 False ["compose_image: " ++ cs uuid ++ " is not a valid build uuid"]
        Right ComposeStatus{..} ->
            if not (queueStatusEnded csQueueStatus)
            then throwError $ createAPIError err400 False ["compose_logs: Build " ++ cs uuid ++ " not in FINISHED or FAILED state."]
            else liftIO (readArtifactFile $ cfgResultsDir </> cs uuid) >>= \case
                Nothing -> throwError $ createAPIError err400 False ["compose_image: Build " ++ cs uuid ++ " is missing image file."]
                Just fn -> do f <- liftIO $ LBS.readFile (cfgResultsDir </> fn)
                              return $ addHeader ("attachment; filename=" ++ filename fn ++ ";") f
 where
    readArtifactFile :: FilePath -> IO (Maybe String)
    readArtifactFile dir =
        CES.catch (Just <$> readFile (dir </> "ARTIFACT"))
                  (\(_ :: CES.IOException) -> return Nothing)
    filename fn = cs uuid ++ "-" ++ takeFileName fn