Merge b364382 into b715dc2

src/BDCS/API/Compose.hs

@@ -109,9 +109,13 @@ instance FromJSON UuidStatus where
 
 data ComposeMsgAsk = AskBuildsWaiting
                    | AskBuildsInProgress
+                   | AskCancelBuild T.Text
                    | AskCompose ComposeInfo
+                   | AskDequeueBuild T.Text
 
-data ComposeMsgResp = RespBuildsWaiting [T.Text]
+data ComposeMsgResp = RespBuildCancelled Bool
+                    | RespBuildDequeued Bool
+                    | RespBuildsWaiting [T.Text]
                     | RespBuildsInProgress [T.Text]
 
 compose :: (MonadBaseControl IO m, MonadLoggerIO m, MonadThrow m) => FilePath -> ConnectionPool -> ComposeInfo -> m ()

src/BDCS/API/Server.hs

@@ -40,7 +40,7 @@ import           BDCS.API.Utils(GitLock(..))
 import           BDCS.API.V0(V0API, v0ApiServer)
 import           BDCS.API.Version(apiVersion)
 import           BDCS.DB(schemaVersion, getDbVersion)
-import           Control.Concurrent.Async(Async, async, concurrently_, waitCatch)
+import           Control.Concurrent.Async(Async, async, cancel, concurrently_, waitCatch)
 import qualified Control.Concurrent.ReadWriteLock as RWL
 import           Control.Concurrent.STM.TChan(newTChan, readTChan)
 import           Control.Concurrent.STM.TVar(TVar, modifyTVar, newTVar, readTVar, writeTVar)
@@ -52,18 +52,18 @@ import           Control.Monad.STM(atomically)
 import           Data.Aeson
 import           Data.Int(Int64)
 import           Data.IORef(IORef, atomicModifyIORef', newIORef, readIORef)
-import           Data.List(uncons)
+import           Data.List(delete, find, uncons)
 import qualified Data.Map as Map
 import           Data.String.Conversions(cs)
 import qualified Data.Text as T
-import           Database.Persist.Sqlite
+import           Database.Persist.Sqlite hiding(delete)
 import           GHC.Conc(retry)
 import qualified GI.Ggit as Git
 import           Network.Wai
 import           Network.Wai.Handler.Warp
 import           Network.Wai.Middleware.Cors
 import           Servant
-import           System.Directory(createDirectoryIfMissing)
+import           System.Directory(createDirectoryIfMissing, removePathForcibly)
 import           System.FilePath.Posix((</>))
 
 type InProgressMap = Map.Map T.Text (Async (), ComposeInfo)
@@ -249,9 +249,41 @@ composeServer ServerConfig{..} = do
             -- And then extract the UUIDs of each, and that's the answer.
             atomically $ putTMVar r (RespBuildsInProgress $ map ciId inProgress)
 
+        (AskCancelBuild buildId, Just r) -> do
+            inProgress <- readIORef inProgressRef
+            case Map.lookup buildId inProgress of
+                Just (thread, ci) -> do cancel thread
+                                        removeCompose inProgressRef buildId
+                                        removePathForcibly (ciResultsDir ci)
+                                        atomically $ putTMVar r (RespBuildCancelled True)
+
+                _                 -> atomically $ putTMVar r (RespBuildCancelled False)
+
         (AskCompose ci, _) ->
             -- Add the new compose to the end of the work queue.  It will eventually
             -- get around to being run by composesThread.
             atomically $ modifyTVar worklist (++ [ci])
 
+        (AskDequeueBuild buildId, Just r) -> do
+            -- The worklist stores ComposeInfo records, but we only get the UUID from the
+            -- client.  So first we have to find the right element in the worklist.  Some
+            -- element with that UUID should be present, but we can't guarantee that given
+            -- all the multiprocessing stuff.  Hence the Maybe.
+            ci <- atomically $ do
+                lst <- readTVar worklist
+                case find (\e -> ciId e == buildId) lst of
+                    Just ele -> modifyTVar worklist (delete ele) >> return (Just ele)
+                    Nothing  -> return Nothing
+
+            -- If we found a ComposeInfo, clean it up - remove the results directory
+            -- (that doesn't yet have an artifact, but should have some toml files) and
+            -- inform the client.  We already removed it from the worklist in the block
+            -- above.
+            case ci of
+                Just ComposeInfo{..} -> do
+                    removePathForcibly ciResultsDir
+                    atomically $ putTMVar r (RespBuildDequeued True)
+
+                Nothing -> atomically $ putTMVar r (RespBuildDequeued False)
+
         _ -> return ()

src/BDCS/API/V0.hs

@@ -194,6 +194,8 @@ type V0API = "projects" :> "list" :> QueryParam "offset" Int
                                     :> 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
@@ -227,6 +229,7 @@ v0ApiServer cfg = projectsListH
              :<|> composeFailedH
              :<|> composeStatusH
              :<|> composeInfoH
+             :<|> composeCancelH
              :<|> composeDeleteH
              :<|> composeLogsH
              :<|> composeImageH
@@ -255,6 +258,7 @@ v0ApiServer cfg = projectsListH
     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)
@@ -2115,6 +2119,38 @@ instance FromJSON ComposeDeleteResponse where
         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.

tests/ServerSpec.hs

@@ -75,6 +75,7 @@ getComposeQueueFinished :: ClientM ComposeFinishedResponse
 getComposeQueueFailed :: ClientM ComposeFailedResponse
 getComposeStatus :: String -> ClientM ComposeStatusResponse
 getComposeInfo :: String -> ClientM ComposeInfoResponse
+getComposeCancel :: String -> ClientM APIResponse
 getComposeDelete :: String -> ClientM ComposeDeleteResponse
 getComposeLogs :: String -> ClientM (Headers '[Header "Content-Disposition" String] LBS.ByteString)
 getComposeImage :: String -> ClientM (Headers '[Header "Content-Disposition" String] LBS.ByteString)
@@ -85,7 +86,7 @@ getStatus :<|> getProjectsList :<|> getProjectsInfo :<|> getProjectsDepsolve
           :<|> getRecipesDepsolve :<|> getRecipesFreeze :<|> getModulesList
           :<|> getModulesList' :<|> getCompose :<|> getComposeTypes :<|> getComposeQueue
           :<|> getComposeQueueFinished :<|> getComposeQueueFailed :<|> getComposeStatus :<|> getComposeInfo
-          :<|> getComposeDelete :<|> getComposeLogs :<|> getComposeImage = client proxyAPI
+          :<|> getComposeCancel :<|> getComposeDelete :<|> getComposeLogs :<|> getComposeImage = client proxyAPI
 
 
 -- Test results, depends on the contents of the ./tests/recipes files.