Added more detailed errors (#31)

* Added more failure statuses

* Added documentation

docs/en/Control_scripts.md

@@ -178,6 +178,11 @@ This script checks the status of the deployment.
 
 If the script exits with `0`, it means that the deployment is healthy and up. If the script exits with a non-zero exit code, it means that the deployment is not healthy or down.
 
+You can specify exactly what error occured using exit codes:
+- `1` – a generic failure.
+- `2` – the deployment is partially down (some containers are unhealthy).
+- `3` – tag mismatch, the deployment has not been updated to the expected version.
+
 This script receives only [the default command-line arguments](#general-behavior) as input.
 
 #### Execution example

docs/ru/Control_scripts.md

@@ -111,6 +111,11 @@ echo "{\"Deployments\": [{\"ResourceName\": \"app-${name}\", \"Namespace\": \"${
 В примере выше используется [_Kubedog_][kubedog].
 Предполагается, что пользователь сам установит [_Kubedog_][kubedog]: сохранит его в `/` контейнера с _Control scripts_ или установит его в `$HOME` из [init](#init).
 
+При помощи exit code можно также сигнализировать какая именно ошибка произошла:
+- `1` – Стандартная ошибка.
+- `2` – Частичная недоступность (некоторые из подов недоступны).
+- `3` – Несоответствие тегов (тег некорректно обновился).
+
 ## cleanup
 
 Реализация очистки ресурсов развертывания.

migrations/deploy/add_detailed_failures.sql

@@ -0,0 +1,14 @@
+-- Deploy octopod:add_detailed_failures to pg
+ BEGIN;
+
+
+ALTER TYPE statuses RENAME VALUE 'Failure' TO 'GenericFailure';
+
+
+ALTER TYPE statuses ADD VALUE IF NOT EXISTS 'TagMismatch';
+
+
+ALTER TYPE statuses ADD VALUE IF NOT EXISTS 'PartialAvailability';
+
+
+COMMIT;

migrations/revert/add_detailed_failures.sql

@@ -0,0 +1,9 @@
+-- Revert octopod:add_detailed_failures from pg
+ BEGIN;
+
+
+ALTER TYPE statuses RENAME VALUE 'GenericFailure' TO 'Failure';
+
+-- NOTE: not a full revert. Removing enum values is a pain.
+
+COMMIT;

migrations/sqitch.plan

@@ -13,3 +13,4 @@ create_deployment_metadata 2020-08-14T12:11:42Z Typeable LLC <octopod@typeable.i
 rename_elements_of_scope_enum 2020-08-19T09:38:40Z Typeable LLC <octopod@typeable.io> # Rename elements of 'scope' enum
 rename-delete-to-archive 2020-11-23T10:53:10Z Ilya <octopod@typeable.io> # Renamed delete to archive
 rename_delete_to_archive_2 2020-11-26T08:28:58Z Typeable LLC <octopod@typeable.io> # Renamed delete to archive
+add_detailed_failures 2021-02-04T11:01:15Z Typeable LLC <octopod@typeable.io> # Added more failure states

migrations/verify/add_detailed_failures.sql

@@ -0,0 +1,10 @@
+-- Verify octopod:add_detailed_failures on pg
+ BEGIN;
+
+
+SELECT ('GenericFailure'::statuses,
+        'TagMismatch'::statuses,
+        'PartialAvailability'::statuses);
+
+
+ROLLBACK;

octopod-backend/octopod-backend.cabal

@@ -44,6 +44,7 @@ library
       Orphans
       TLS
       Types
+      Database.PostgreSQL.Simple.Instances
   hs-source-dirs:
       src
   build-depends:
@@ -91,6 +92,7 @@ library
     , x509
     , x509-store
     , x509-validation
+    , containers
   default-language: Haskell2010
 
 executable octopod-exe

octopod-backend/src/Database/PostgreSQL/Simple/Instances.hs

@@ -0,0 +1,40 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Database.PostgreSQL.Simple.Instances
+  (
+  ) where
+
+import           Common.Types
+import           Control.Applicative
+import           Control.Arrow
+import qualified Data.Map as M
+import           Data.Text (Text)
+import           Database.PostgreSQL.Simple.FromField
+import           Database.PostgreSQL.Simple.ToField
+
+deploymentStatusText :: DeploymentStatus -> Text
+deploymentStatusText Running = "Running"
+deploymentStatusText (Failure GenericFailure) = "GenericFailure"
+deploymentStatusText (Failure TagMismatch) = "TagMismatch"
+deploymentStatusText (Failure PartialAvailability) = "PartialAvailability"
+deploymentStatusText CreatePending = "CreatePending"
+deploymentStatusText UpdatePending = "UpdatePending"
+deploymentStatusText ArchivePending = "ArchivePending"
+deploymentStatusText Archived = "Archived"
+
+instance ToField DeploymentStatus where
+  toField = toField @Text . deploymentStatusText
+
+instance FromField DeploymentStatus where
+  fromField f b = fromField f b >>= maybe empty return . flip M.lookup m
+    where
+      m = M.fromList . fmap (deploymentStatusText &&& id) $
+        [ Running
+        , Failure GenericFailure
+        , Failure TagMismatch
+        , Failure PartialAvailability
+        , CreatePending
+        , UpdatePending
+        , ArchivePending
+        , Archived
+        ]

octopod-backend/src/Octopod/Server.hs

@@ -26,6 +26,7 @@ import           Data.Text (lines, pack, unpack, unwords)
 import           Data.Text.IO (hGetContents)
 import           Data.Traversable
 import           Database.PostgreSQL.Simple
+import           Database.PostgreSQL.Simple.Instances ()
 import           Network.Wai.Handler.Warp
 import           Network.Wai.Handler.WarpTLS
 import           Options.Generic
@@ -309,7 +310,7 @@ getFullInfo listType = do
       dMeta <- selectDeploymentMetadata conn n
       pure $ do
         let dep = (Deployment n t appOvs depOvs)
-        DeploymentFullInfo dep (read st) a dMeta ct ut
+        DeploymentFullInfo dep st a dMeta ct ut
   liftIO . logInfo l $ "get deployments: " <> (pack . show $ deployments)
   return deployments
   where
@@ -344,7 +345,7 @@ createH dep = do
     createDep :: PgPool -> Deployment -> IO [Only Int]
     createDep p Deployment { name = n, tag = t } =
       withResource p $ \conn ->
-        query conn q (n, t, show CreatePending)
+        query conn q (n, t, CreatePending)
   failIfImageNotFound (name dep) (tag dep)
   failIfGracefulShutdownActivated
   res :: Either SqlError [Only Int] <- liftIO . try $ createDep pgPool dep
@@ -554,7 +555,7 @@ archiveDeployment p dName = withResource p $ \conn -> do
       \SET archived = 't', archived_at = now(), \
         \status = ?, status_updated_at = now() \
       \WHERE name = ?"
-  execute conn q (show ArchivePending, dName)
+  execute conn q (ArchivePending, dName)
 
 -- | Handles the 'update' request.
 updateH :: DeploymentName -> DeploymentUpdate -> AppM CommandResponse
@@ -743,7 +744,7 @@ updateDeployment conn dName dTag = do
       \SET tag = ?, updated_at = now(), \
         \status = ?, status_updated_at = now() \
       \WHERE name = ?"
-  execute conn q (dTag, show UpdatePending, dName)
+  execute conn q (dTag, UpdatePending, dName)
 
 -- | Handles the 'info' request of the Web UI API.
 infoH :: DeploymentName -> AppM [DeploymentInfo]
@@ -1069,7 +1070,6 @@ upsertDeploymentMetadata
   -> [DeploymentMetadata]
   -> IO ()
 upsertDeploymentMetadata pgPool dName dMetadatas = do
-  let
   withResource pgPool $ \conn -> withTransactionSerializable conn $ do
     void $ execute
       conn
@@ -1148,11 +1148,11 @@ runStatusUpdater state = do
       "UPDATE deployments SET checked_at = now() WHERE name = ? and status = ?"
 
   forever $ do
-    rows :: [(DeploymentName, Text, Int)] <- liftIO $
+    rows :: [(DeploymentName, DeploymentStatus, Int)] <- liftIO $
       withResource pgPool $ \conn -> query conn selectDeps (Only interval)
     let
       checkList :: [(DeploymentName, DeploymentStatus, Timestamp)] =
-        (\(n, s, t) -> (n, read . unpack $ s, coerce t)) <$> rows
+        (\(n, s, t) -> (n, s, coerce t)) <$> rows
     checkResult <- for checkList $ \(dName, dStatus, ts) -> do
       let
         args              =
@@ -1169,8 +1169,8 @@ runStatusUpdater state = do
       for (zip checkList checkResult) $ \((dName, oldSt, _), (_, newSt, _)) ->
         withResource pgPool $ \conn ->
           if oldSt == newSt
-            then execute conn updateCheckedAt (dName, show oldSt)
+            then execute conn updateCheckedAt (dName, oldSt)
-            else execute conn updateStatus (show newSt, dName, show oldSt)
+            else execute conn updateStatus (newSt, dName, oldSt)
     if checkList == checkResult
       then pure ()
       else sendReloadEvent state
@@ -1185,14 +1185,19 @@ newStatus
   -> DeploymentStatus
 newStatus ExitSuccess     ArchivePending _ _ = Archived
 newStatus ExitSuccess     _             _ _ = Running
-newStatus (ExitFailure _) Running       _ _ = Failure
+newStatus (ExitFailure n) Running       _ _ = Failure $ failureStatusType n
-newStatus (ExitFailure _) CreatePending ts timeout | ts > coerce timeout =
+newStatus (ExitFailure n) CreatePending ts timeout | ts > coerce timeout =
-  Failure
+  Failure $ failureStatusType n
-newStatus (ExitFailure _) UpdatePending ts timeout | ts > coerce timeout =
+newStatus (ExitFailure n) UpdatePending ts timeout | ts > coerce timeout =
-  Failure
+  Failure $ failureStatusType n
 newStatus (ExitFailure _) ArchivePending _ _ = ArchivePending
 newStatus (ExitFailure _) oldStatus     _ _ = oldStatus
 
+failureStatusType :: Int -> FailureType
+failureStatusType 2 = PartialAvailability
+failureStatusType 3 = TagMismatch
+failureStatusType _ = GenericFailure
+
 -- | Checks if graceful shutdown has been activated activated.
 -- Returns 405 'Graceful shutdown activated' response
 -- if graceful shutdown has been activated.

octopod-common/src/Common/Types.hs

@@ -86,7 +86,7 @@ newtype ProjectName = ProjectName { uProjectName :: Text }
 
 data DeploymentStatus
   = Running
-  | Failure
+  | Failure FailureType
   | CreatePending
   | UpdatePending
   | ArchivePending
@@ -94,6 +94,13 @@ data DeploymentStatus
   deriving (Generic, Read, Show, Eq)
   deriving (FromJSON, ToJSON) via Snake DeploymentStatus
 
+data FailureType
+  = GenericFailure
+  | TagMismatch
+  | PartialAvailability
+  deriving (Generic, Read, Show, Eq)
+  deriving (FromJSON, ToJSON) via Snake FailureType
+
 data Deployment = Deployment
   { name :: DeploymentName
   , tag :: DeploymentTag

octopod-common/src/Common/Utils.hs

@@ -34,7 +34,7 @@ dfiName = field @"deployment" . field @"name"
 isPending :: DeploymentStatus -> Bool
 isPending = \case
   Running -> False
-  Failure -> False
+  Failure _ -> False
   Archived -> False
   CreatePending -> True
   UpdatePending -> True

octopod-frontend/src/Frontend/Utils.hs

@@ -358,7 +358,7 @@ statusWidget stDyn = do
     pendingWidget = divClass "loading loading--status-alike"
   dyn_ $ stDyn' <&> \case
     Running -> divClass "status status--success" $ text "Running"
-    Failure -> divClass "status status--failure" $ text "Failure"
+    Failure _ -> divClass "status status--failure" $ text "Failure"
     CreatePending -> pendingWidget $ text "Creating..."
     UpdatePending -> pendingWidget $ text "Updating..."
     ArchivePending -> pendingWidget $ text "Archiving..."