Cleanup stern (#845)

* More error info in backoffice UI.

This helps customer support to understand errors they run into without
consulting the server logs.  Stern is an internal tool, so it's ok to
be a little more generous with information on internal errors.

* Better types.

* Re-throw expected errors from galley (don't throw 5xx).

* Cleanup.

libs/bilge/src/Bilge/Request.hs

@@ -28,7 +28,7 @@ module Bilge.Request
     , showRequest
     , noRedirect
     , timeout
-    , expect2xx, expect3xx, expect4xx
+    , expect2xx, expect3xx, expect4xx, expectStatus
     , checkStatus
     , cookie
     , cookieRaw

services/galley/src/Galley/API/Teams.hs

@@ -532,18 +532,18 @@ getLegalholdStatus (uid ::: tid ::: ct) = do
 -- | Get SSO status for a team.
 getSSOStatusInternal :: TeamId ::: JSON -> Galley Response
 getSSOStatusInternal (tid ::: _) = do
-    defConfig <- do
+    defConfig :: SSOTeamConfig <- do
         featureSSO <- view (options . optSettings . setFeatureFlags . flagSSO)
         pure . SSOTeamConfig $ case featureSSO of
             FeatureSSOEnabledByDefault  -> SSOEnabled
             FeatureSSODisabledByDefault -> SSODisabled
-    ssoTeamConfig <- SSOData.getSSOTeamConfig tid
+    ssoTeamConfig :: Maybe SSOTeamConfig <- SSOData.getSSOTeamConfig tid
     pure . json . fromMaybe defConfig $ ssoTeamConfig
 
 -- | Enable or disable SSO for a team.
 setSSOStatusInternal :: TeamId ::: JsonRequest SSOTeamConfig ::: JSON -> Galley Response
 setSSOStatusInternal (tid ::: req ::: _) = do
-    ssoTeamConfig <- fromJsonBody req
+    ssoTeamConfig :: SSOTeamConfig <- fromJsonBody req
     case ssoTeamConfigStatus ssoTeamConfig of
         SSODisabled -> throwM disableSsoNotImplemented
         SSOEnabled  -> pure () -- this one is easy to implement :)

tools/stern/src/Stern/API.hs

@@ -5,8 +5,6 @@
 {-# LANGUAGE ViewPatterns      #-}
 {-# LANGUAGE LambdaCase        #-}
 
-{-# OPTIONS_GHC -Wno-unused-binds #-}
-
 module Stern.API (start) where
 
 import Imports hiding (head)
@@ -297,26 +295,50 @@ sitemap = do
 
     -- feature flags
 
-    get "/teams/:tid/features/sso" (continue getSSOStatus) $
+    get "/teams/:tid/features/legalhold" (continue (liftM json . Intra.getLegalholdStatus)) $
+        capture "tid"
+
+    document "GET" "getLegalholdStatus" $ do
+        summary "Shows whether legalhold feature is enabled for team"
+        Doc.parameter Doc.Path "tid" Doc.bytes' $
+            description "Team ID"
+        Doc.returns Doc.docSetLegalHoldStatus
+        Doc.response 200 "Legalhold status" Doc.end
+        Doc.returns Doc.bool'
+
+    put "/teams/:tid/features/legalhold" (continue setLegalholdStatus) $
+        contentType "application" "json"
+        .&. capture "tid"
+        .&. jsonRequest @SetLegalHoldStatus
+
+    document "PUT" "setLegalholdStatus" $ do
+        summary "Disable / enable legalhold feature for team"
+        Doc.parameter Doc.Path "tid" Doc.bytes' $
+            description "Team ID"
+        Doc.body Doc.docSetLegalHoldStatus $
+            Doc.description "JSON body"
+        Doc.response 200 "Legalhold status" Doc.end
+
+    get "/teams/:tid/features/sso" (continue (liftM json . Intra.getSSOStatus)) $
         capture "tid"
 
     document "GET" "getSSOStatus" $ do
         summary "Shows whether SSO feature is enabled for team"
         Doc.parameter Doc.Path "tid" Doc.bytes' $
             description "Team ID"
-        Doc.returns Doc.bool'
+        Doc.returns Doc.docSetSSOStatus
         Doc.response 200 "SSO status" Doc.end
 
     put "/teams/:tid/features/sso" (continue setSSOStatus) $
         contentType "application" "json"
         .&. capture "tid"
-        .&. jsonRequest @Bool
+        .&. jsonRequest @SetSSOStatus
 
     document "PUT" "setSSOStatus" $ do
         summary "Disable / enable SSO feature for team"
         Doc.parameter Doc.Path "tid" Doc.bytes' $
             description "Team ID"
-        Doc.body Doc.bool' $
+        Doc.body Doc.docSetSSOStatus $
             Doc.description "JSON body"
         Doc.response 200 "SSO status" Doc.end
 
@@ -512,21 +534,15 @@ getTeamInfo :: TeamId -> Handler Response
 getTeamInfo = liftM json . Intra.getTeamInfo
 
 
-getLegalholdStatus :: TeamId -> Handler Response
-getLegalholdStatus = liftM json . Intra.getLegalholdStatus
-
-setLegalholdStatus :: JSON ::: TeamId ::: JsonRequest Bool -> Handler Response
+setLegalholdStatus :: JSON ::: TeamId ::: JsonRequest SetLegalHoldStatus -> Handler Response
 setLegalholdStatus (_ ::: tid ::: req) = do
     status <- parseBody req !>> Error status400 "client-error"
     liftM json $ Intra.setLegalholdStatus tid status
 
-getSSOStatus :: TeamId -> Handler Response
-getSSOStatus = liftM json . Intra.getSSOStatus
-
-setSSOStatus :: JSON ::: TeamId ::: JsonRequest Bool -> Handler Response
+setSSOStatus :: JSON ::: TeamId ::: JsonRequest SetSSOStatus -> Handler Response
 setSSOStatus (_ ::: tid ::: req) = do
-  status <- parseBody req !>> Error status400 "client-error"
-  liftM json $ Intra.setSSOStatus tid status
+    status :: SetSSOStatus <- parseBody req !>> Error status400 "client-error"
+    liftM json $ Intra.setSSOStatus tid status
 
 getTeamBillingInfo :: TeamId -> Handler Response
 getTeamBillingInfo tid = do

tools/stern/src/Stern/Intra.hs

@@ -50,7 +50,6 @@ import Stern.App
 import Control.Error
 import Control.Lens (view, (^.))
 import Control.Monad.Reader
-import Control.Monad.Catch (throwM)
 import Data.Aeson hiding (Error)
 import Data.Aeson.Types (emptyArray)
 import Data.ByteString (ByteString)
@@ -67,7 +66,6 @@ import Galley.Types.Teams
 import Galley.Types.Teams.Intra
 import Galley.Types.Teams.SSO
 import Gundeck.Types
-import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), checkResponse)
 import Network.HTTP.Types.Method
 import Network.HTTP.Types.Status hiding (statusCode)
 import Network.Wai.Utilities (Error (..))
@@ -281,7 +279,7 @@ getInvoiceUrl tid iid = do
           ( method GET
           . paths ["i", "team", toByteString' tid, "invoice", toByteString' iid]
           . noRedirect
-          . expect [status307]
+          . expectStatus (== 307)
           )
     return $ getHeader' "Location" r
 
@@ -351,7 +349,7 @@ setBlacklistStatus status emailOrPhone = do
     statusToMethod False = DELETE
     statusToMethod True  = POST
 
-getLegalholdStatus :: TeamId -> Handler Bool
+getLegalholdStatus :: TeamId -> Handler SetLegalHoldStatus
 getLegalholdStatus tid = do
     info $ msg "Getting legalhold status"
     gly <- view galley
@@ -361,28 +359,30 @@ getLegalholdStatus tid = do
          . expect2xx
          )
   where
-    fromResponseBody :: Response (Maybe LByteString) -> Handler Bool
+    fromResponseBody :: Response (Maybe LByteString) -> Handler SetLegalHoldStatus
     fromResponseBody resp = case responseJsonEither resp of
-      Right (LegalHoldTeamConfig LegalHoldDisabled) -> pure False
-      Right (LegalHoldTeamConfig LegalHoldEnabled) -> pure True
+      Right (LegalHoldTeamConfig LegalHoldDisabled) -> pure SetLegalHoldDisabled
+      Right (LegalHoldTeamConfig LegalHoldEnabled) -> pure SetLegalHoldEnabled
       Left errmsg -> throwE (Error status502 "bad-upstream" ("bad response; error message: " <> pack errmsg))
 
-setLegalholdStatus :: TeamId -> Bool -> Handler ()
+setLegalholdStatus :: TeamId -> SetLegalHoldStatus -> Handler ()
 setLegalholdStatus tid status = do
     info $ msg "Setting legalhold status"
     gly <- view galley
-    void . catchRpcErrors $ rpc' "galley" gly
+    resp <- catchRpcErrors $ rpc' "galley" gly
          ( method PUT
          . paths ["/i/teams", toByteString' tid, "features", "legalhold"]
          . lbytes (encode $ toRequestBody status)
          . contentJson
-         . expect2xx
          )
+    case statusCode resp of
+      204 -> pure ()
+      _   -> throwE $ responseJsonUnsafe resp
   where
-    toRequestBody False = LegalHoldTeamConfig LegalHoldDisabled
-    toRequestBody True  = LegalHoldTeamConfig LegalHoldEnabled
+    toRequestBody SetLegalHoldDisabled = LegalHoldTeamConfig LegalHoldDisabled
+    toRequestBody SetLegalHoldEnabled  = LegalHoldTeamConfig LegalHoldEnabled
 
-getSSOStatus :: TeamId -> Handler Bool
+getSSOStatus :: TeamId -> Handler SetSSOStatus
 getSSOStatus tid = do
     info $ msg "Getting SSO status"
     gly <- view galley
@@ -392,42 +392,34 @@ getSSOStatus tid = do
          . expect2xx
          )
   where
-    fromResponseBody :: Response (Maybe LByteString) -> Handler Bool
+    fromResponseBody :: Response (Maybe LByteString) -> Handler SetSSOStatus
     fromResponseBody resp = case responseJsonEither resp of
-      Right (SSOTeamConfig SSODisabled) -> pure False
-      Right (SSOTeamConfig SSOEnabled) -> pure True
+      Right (SSOTeamConfig SSOEnabled) -> pure SetSSOEnabled
+      Right (SSOTeamConfig SSODisabled) -> pure SetSSODisabled
       Left errmsg -> throwE (Error status502 "bad-upstream" ("bad response; error message: " <> pack errmsg))
 
-setSSOStatus :: TeamId -> Bool -> Handler ()
+setSSOStatus :: TeamId -> SetSSOStatus -> Handler ()
 setSSOStatus tid status = do
     info $ msg "Setting SSO status"
     gly <- view galley
-    void . catchRpcErrors $ rpc' "galley" gly
+    resp <- catchRpcErrors $ rpc' "galley" gly
          ( method PUT
          . paths ["/i/teams", toByteString' tid, "features", "sso"]
          . lbytes (encode $ toRequestBody status)
          . contentJson
-         . expect2xx
          )
+    case statusCode resp of
+      204 -> pure ()
+      _   -> throwE $ responseJsonUnsafe resp
   where
-    toRequestBody False = SSOTeamConfig SSODisabled
-    toRequestBody True  = SSOTeamConfig SSOEnabled
+    toRequestBody SetSSODisabled = SSOTeamConfig SSODisabled
+    toRequestBody SetSSOEnabled  = SSOTeamConfig SSOEnabled
 
 --------------------------------------------------------------------------------
 -- Helper functions
 stripBS :: ByteString -> ByteString
 stripBS = encodeUtf8 . strip . decodeUtf8
 
--- TODO: Move this to Bilge after merging the current PR's
-expect :: [Status] -> Request -> Request
-expect ss rq = rq { checkResponse = check }
-  where
-    check rq' rs = do
-        let s   = responseStatus rs
-            rs' = rs { responseBody = () }
-        when (statusIsServerError s || s `notElem` ss) $
-            throwM $ HttpExceptionRequest rq' (StatusCodeException rs' mempty)
-
 userKeyToParam :: Either Email Phone -> Request -> Request
 userKeyToParam (Left e)  = queryItem "email" (stripBS $ toByteString' e)
 userKeyToParam (Right p) = queryItem "phone" (stripBS $ toByteString' p)
@@ -441,7 +433,7 @@ catchRpcErrors action = ExceptT $ catch (Right <$> action) catchRPCException
     catchRPCException :: RPCException -> App (Either Error a)
     catchRPCException rpcE = do
       Log.err $ rpcExceptionMsg rpcE
-      pure . Left $ Error status500 "io-error" "I/O Error"
+      pure . Left $ Error status500 "io-error" (pack $ show rpcE)
 
 getTeamData :: TeamId -> Handler TeamData
 getTeamData tid = do
@@ -450,7 +442,7 @@ getTeamData tid = do
     r <- catchRpcErrors $ rpc' "galley" g
          ( method GET
          . paths ["i", "teams", toByteString' tid]
-         . expect [status200, status404]
+         . expectStatus (`elem` [200, 404])
          )
     case Bilge.statusCode r of
         200 -> parseResponse (Error status502 "bad-upstream") r
@@ -500,7 +492,7 @@ getMarketoResult email = do
     r <- catchRpcErrors $ rpc' "galeb" g
          ( method GET
          . paths ["/i/marketo/emails", toByteString' email]
-         . expect [status200, status404]
+         . expectStatus (`elem` [200, 404])
          )
     -- 404 is acceptable when marketo doesn't know about this user, return an empty result
     case statusCode r of
@@ -620,7 +612,7 @@ getUserNotifications uid = do
              . path "/notifications"
              . queryItem "size" (toByteString' batchSize)
              . maybe id (queryItem "since" . toByteString') start
-             . expect [status200, status404]
+             . expectStatus (`elem` [200, 404])
              )
         -- 404 is an acceptable response, in case, for some reason,
         -- "start" is not found we still return a QueuedNotificationList

tools/stern/src/Stern/Swagger.hs

@@ -3,6 +3,7 @@
 module Stern.Swagger where
 
 import Data.Swagger.Build.Api
+import Stern.Types
 import Imports
 
 sternModels :: [Model]
@@ -71,3 +72,15 @@ teamBillingInfoUpdate = defineModel "teamBillingInfoUpdate" $ do
     property "state" string' $ do
         description "State of the company address (1 - 256 characters)"
         optional
+
+docSetSSOStatus :: DataType
+docSetSSOStatus = docBoundedEnum @SetSSOStatus
+
+docSetLegalHoldStatus :: DataType
+docSetLegalHoldStatus = docBoundedEnum @SetLegalHoldStatus
+
+-- (the double-call to show is to add extra double-quotes to the string.  this is important
+-- because the json instances also render this into a json string, and json string are wrapped
+-- in double-quotes.)
+docBoundedEnum :: forall a. (Bounded a, Enum a, Show a) => DataType
+docBoundedEnum = string . enum $ show . show <$> [(minBound :: a)..]

tools/stern/src/Stern/Types.hs

@@ -94,3 +94,13 @@ data TeamBillingInfoUpdate = TeamBillingInfoUpdate
     } deriving (Eq, Show)
 
 deriveJSON toJSONFieldName ''TeamBillingInfoUpdate
+
+data SetLegalHoldStatus = SetLegalHoldDisabled | SetLegalHoldEnabled
+  deriving (Eq, Show, Ord, Enum, Bounded, Generic)
+
+deriveJSON toJSONFieldName ''SetLegalHoldStatus
+
+data SetSSOStatus = SetSSODisabled | SetSSOEnabled
+  deriving (Eq, Show, Ord, Enum, Bounded, Generic)
+
+deriveJSON toJSONFieldName ''SetSSOStatus