content: --
  -- MinIO Haskell SDK, (C) 2018-2023 MinIO, Inc.
  --
  -- Licensed under the Apache License, Version 2.0 (the "License");
  -- you may not use this file except in compliance with the License.
  -- You may obtain a copy of the License at
  --
  --     http://www.apache.org/licenses/LICENSE-2.0
  --
  -- Unless required by applicable law or agreed to in writing, software
  -- distributed under the License is distributed on an "AS IS" BASIS,
  -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  -- See the License for the specific language governing permissions and
  -- limitations under the License.
  --
  
  module Network.Minio.AdminAPI
    ( -- * MinIO Admin API
  
      --------------------
  
      -- | Provides MinIO admin API and related types. It is in
      -- experimental state.
      DriveInfo (..),
      ErasureInfo (..),
      Backend (..),
      ConnStats (..),
      HttpStats (..),
      ServerProps (..),
      CountNAvgTime (..),
      StorageClass (..),
      StorageInfo (..),
      SIData (..),
      ServerInfo (..),
      getServerInfo,
      HealOpts (..),
      HealResultItem (..),
      HealStatus (..),
      HealStartResp (..),
      startHeal,
      forceStartHeal,
      getHealStatus,
      SetConfigResult (..),
      NodeSummary (..),
      setConfig,
      getConfig,
      ServerVersion (..),
      ServiceStatus (..),
      serviceStatus,
      ServiceAction (..),
      serviceSendAction,
    )
  where
  
  import Data.Aeson
    ( FromJSON,
      ToJSON,
      Value (Object),
      eitherDecode,
      object,
      pairs,
      parseJSON,
      toEncoding,
      toJSON,
      withObject,
      withText,
      (.:),
      (.:?),
      (.=),
    )
  import qualified Data.Aeson as A
  import Data.Aeson.Types (typeMismatch)
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Lazy as LBS
  import qualified Data.Text as T
  import Data.Time (NominalDiffTime, getCurrentTime)
  import Lib.Prelude
  import Network.HTTP.Conduit (Response)
  import qualified Network.HTTP.Conduit as NC
  import qualified Network.HTTP.Types as HT
  import Network.HTTP.Types.Header (hHost)
  import Network.Minio.APICommon
  import Network.Minio.Credentials
  import Network.Minio.Data
  import Network.Minio.Errors
  import Network.Minio.Sign.V4
  import Network.Minio.Utils
  
  data DriveInfo = DriveInfo
    { diUuid :: Text,
      diEndpoint :: Text,
      diState :: Text
    }
    deriving stock (Show, Eq)
  
  instance FromJSON DriveInfo where
    parseJSON = withObject "DriveInfo" $ \v ->
      DriveInfo
        <$> v
          .: "uuid"
        <*> v
          .: "endpoint"
        <*> v
          .: "state"
  
  data StorageClass = StorageClass
    { scParity :: Int,
      scData :: Int
    }
    deriving stock (Show, Eq)
  
  data ErasureInfo = ErasureInfo
    { eiOnlineDisks :: Int,
      eiOfflineDisks :: Int,
      eiStandard :: StorageClass,
      eiReducedRedundancy :: StorageClass,
      eiSets :: [[DriveInfo]]
    }
    deriving stock (Show, Eq)
  
  instance FromJSON ErasureInfo where
    parseJSON = withObject "ErasureInfo" $ \v -> do
      onlineDisks <- v .: "OnlineDisks"
      offlineDisks <- v .: "OfflineDisks"
      stdClass <-
        StorageClass
          <$> v
            .: "StandardSCData"
          <*> v
            .: "StandardSCParity"
      rrClass <-
        StorageClass
          <$> v
            .: "RRSCData"
          <*> v
            .: "RRSCParity"
      sets <- v .: "Sets"
      return $ ErasureInfo onlineDisks offlineDisks stdClass rrClass sets
  
  data Backend
    = BackendFS
    | BackendErasure ErasureInfo
    deriving stock (Show, Eq)
  
  instance FromJSON Backend where
    parseJSON = withObject "Backend" $ \v -> do
      typ <- v .: "Type"
      case typ :: Int of
        1 -> return BackendFS
        2 -> BackendErasure <$> parseJSON (Object v)
        _ -> typeMismatch "BackendType" (Object v)
  
  data ConnStats = ConnStats
    { csTransferred :: Int64,
      csReceived :: Int64
    }
    deriving stock (Show, Eq)
  
  instance FromJSON ConnStats where
    parseJSON = withObject "ConnStats" $ \v ->
      ConnStats
        <$> v
          .: "transferred"
        <*> v
          .: "received"
  
  data ServerProps = ServerProps
    { spUptime :: NominalDiffTime,
      spVersion :: Text,
      spCommitId :: Text,
      spRegion :: Text,
      spSqsArns :: [Text]
    }
    deriving stock (Show, Eq)
  
  instance FromJSON ServerProps where
    parseJSON = withObject "SIServer" $ \v -> do
      uptimeNs <- v .: "uptime"
      let uptime = uptimeNs / 1e9
      ver <- v .: "version"
      commitId <- v .: "commitID"
      region <- v .: "region"
      arn <- v .: "sqsARN"
      return $ ServerProps uptime ver commitId region arn
  
  data StorageInfo = StorageInfo
    { siUsed :: Int64,
      siBackend :: Backend
    }
    deriving stock (Show, Eq)
  
  instance FromJSON StorageInfo where
    parseJSON = withObject "StorageInfo" $ \v ->
      StorageInfo
        <$> v
          .: "Used"
        <*> v
          .: "Backend"
  
  data CountNAvgTime = CountNAvgTime
    { caCount :: Int64,
      caAvgDuration :: Text
    }
    deriving stock (Show, Eq)
  
  instance FromJSON CountNAvgTime where
    parseJSON = withObject "CountNAvgTime" $ \v ->
      CountNAvgTime
        <$> v
          .: "count"
        <*> v
          .: "avgDuration"
  
  data HttpStats = HttpStats
    { hsTotalHeads :: CountNAvgTime,
      hsSuccessHeads :: CountNAvgTime,
      hsTotalGets :: CountNAvgTime,
      hsSuccessGets :: CountNAvgTime,
      hsTotalPuts :: CountNAvgTime,
      hsSuccessPuts :: CountNAvgTime,
      hsTotalPosts :: CountNAvgTime,
      hsSuccessPosts :: CountNAvgTime,
      hsTotalDeletes :: CountNAvgTime,
      hsSuccessDeletes :: CountNAvgTime
    }
    deriving stock (Show, Eq)
  
  instance FromJSON HttpStats where
    parseJSON = withObject "HttpStats" $ \v ->
      HttpStats
        <$> v
          .: "totalHEADs"
        <*> v
          .: "successHEADs"
        <*> v
          .: "totalGETs"
        <*> v
          .: "successGETs"
        <*> v
          .: "totalPUTs"
        <*> v
          .: "successPUTs"
        <*> v
          .: "totalPOSTs"
        <*> v
          .: "successPOSTs"
        <*> v
          .: "totalDELETEs"
        <*> v
          .: "successDELETEs"
  
  data SIData = SIData
    { sdStorage :: StorageInfo,
      sdConnStats :: ConnStats,
      sdHttpStats :: HttpStats,
      sdProps :: ServerProps
    }
    deriving stock (Show, Eq)
  
  instance FromJSON SIData where
    parseJSON = withObject "SIData" $ \v ->
      SIData
        <$> v
          .: "storage"
        <*> v
          .: "network"
        <*> v
          .: "http"
        <*> v
          .: "server"
  
  data ServerInfo = ServerInfo
    { siError :: Text,
      siAddr :: Text,
      siData :: SIData
    }
    deriving stock (Show, Eq)
  
  instance FromJSON ServerInfo where
    parseJSON = withObject "ServerInfo" $ \v ->
      ServerInfo
        <$> v
          .: "error"
        <*> v
          .: "addr"
        <*> v
          .: "data"
  
  data ServerVersion = ServerVersion
    { svVersion :: Text,
      svCommitId :: Text
    }
    deriving stock (Show, Eq)
  
  instance FromJSON ServerVersion where
    parseJSON = withObject "ServerVersion" $ \v ->
      ServerVersion
        <$> v
          .: "version"
        <*> v
          .: "commitID"
  
  data ServiceStatus = ServiceStatus
    { ssVersion :: ServerVersion,
      ssUptime :: NominalDiffTime
    }
    deriving stock (Show, Eq)
  
  instance FromJSON ServiceStatus where
    parseJSON = withObject "ServiceStatus" $ \v -> do
      serverVersion <- v .: "serverVersion"
      uptimeNs <- v .: "uptime"
      let uptime = uptimeNs / 1e9
      return $ ServiceStatus serverVersion uptime
  
  data ServiceAction
    = ServiceActionRestart
    | ServiceActionStop
    deriving stock (Show, Eq)
  
  instance ToJSON ServiceAction where
    toJSON a = object ["action" .= serviceActionToText a]
  
  serviceActionToText :: ServiceAction -> Text
  serviceActionToText a = case a of
    ServiceActionRestart -> "restart"
    ServiceActionStop -> "stop"
  
  adminPath :: ByteString
  adminPath = "/minio/admin"
  
  data HealStartResp = HealStartResp
    { hsrClientToken :: Text,
      hsrClientAddr :: Text,
      hsrStartTime :: UTCTime
    }
    deriving stock (Show, Eq)
  
  instance FromJSON HealStartResp where
    parseJSON = withObject "HealStartResp" $ \v ->
      HealStartResp
        <$> v
          .: "clientToken"
        <*> v
          .: "clientAddress"
        <*> v
          .: "startTime"
  
  data HealOpts = HealOpts
    { hoRecursive :: Bool,
      hoDryRun :: Bool
    }
    deriving stock (Show, Eq)
  
  instance ToJSON HealOpts where
    toJSON (HealOpts r d) =
      object ["recursive" .= r, "dryRun" .= d]
    toEncoding (HealOpts r d) =
      pairs ("recursive" .= r <> "dryRun" .= d)
  
  instance FromJSON HealOpts where
    parseJSON = withObject "HealOpts" $ \v ->
      HealOpts
        <$> v
          .: "recursive"
        <*> v
          .: "dryRun"
  
  data HealItemType
    = HealItemMetadata
    | HealItemBucket
    | HealItemBucketMetadata
    | HealItemObject
    deriving stock (Show, Eq)
  
  instance FromJSON HealItemType where
    parseJSON = withText "HealItemType" $ \v -> case v of
      "metadata" -> return HealItemMetadata
      "bucket" -> return HealItemBucket
      "object" -> return HealItemObject
      "bucket-metadata" -> return HealItemBucketMetadata
      _ -> typeMismatch "HealItemType" (A.String v)
  
  data NodeSummary = NodeSummary
    { nsName :: Text,
      nsErrSet :: Bool,
      nsErrMessage :: Text
    }
    deriving stock (Show, Eq)
  
  instance FromJSON NodeSummary where
    parseJSON = withObject "NodeSummary" $ \v ->
      NodeSummary
        <$> v
          .: "name"
        <*> v
          .: "errSet"
        <*> v
          .: "errMsg"
  
  data SetConfigResult = SetConfigResult
    { scrStatus :: Bool,
      scrNodeSummary :: [NodeSummary]
    }
    deriving stock (Show, Eq)
  
  instance FromJSON SetConfigResult where
    parseJSON = withObject "SetConfigResult" $ \v ->
      SetConfigResult
        <$> v
          .: "status"
        <*> v
          .: "nodeResults"
  
  data HealResultItem = HealResultItem
    { hriResultIdx :: Int,
      hriType :: HealItemType,
      hriBucket :: Bucket,
      hriObject :: Object,
      hriDetail :: Text,
      hriParityBlocks :: Maybe Int,
      hriDataBlocks :: Maybe Int,
      hriDiskCount :: Int,
      hriSetCount :: Int,
      hriObjectSize :: Int,
      hriBefore :: [DriveInfo],
      hriAfter :: [DriveInfo]
    }
    deriving stock (Show, Eq)
  
  instance FromJSON HealResultItem where
    parseJSON = withObject "HealResultItem" $ \v ->
      HealResultItem
        <$> v
          .: "resultId"
        <*> v
          .: "type"
        <*> v
          .: "bucket"
        <*> v
          .: "object"
        <*> v
          .: "detail"
        <*> v
          .:? "parityBlocks"
        <*> v
          .:? "dataBlocks"
        <*> v
          .: "diskCount"
        <*> v
          .: "setCount"
        <*> v
          .: "objectSize"
        <*> ( do
                before <- v .: "before"
                before .: "drives"
            )
        <*> ( do
                after <- v .: "after"
                after .: "drives"
            )
  
  data HealStatus = HealStatus
    { hsSummary :: Text,
      hsStartTime :: UTCTime,
      hsSettings :: HealOpts,
      hsNumDisks :: Int,
      hsFailureDetail :: Maybe Text,
      hsItems :: Maybe [HealResultItem]
    }
    deriving stock (Show, Eq)
  
  instance FromJSON HealStatus where
    parseJSON = withObject "HealStatus" $ \v ->
      HealStatus
        <$> v
          .: "Summary"
        <*> v
          .: "StartTime"
        <*> v
          .: "Settings"
        <*> v
          .: "NumDisks"
        <*> v
          .:? "Detail"
        <*> v
          .: "Items"
  
  healPath :: Maybe Bucket -> Maybe Text -> ByteString
  healPath bucket prefix = do
    if isJust bucket
      then
        encodeUtf8 $
          "v1/heal/"
            <> fromMaybe "" bucket
            <> "/"
            <> fromMaybe "" prefix
      else encodeUtf8 ("v1/heal/" :: Text)
  
  -- | Get server version and uptime.
  serviceStatus :: Minio ServiceStatus
  serviceStatus = do
    rsp <-
      executeAdminRequest
        AdminReqInfo
          { ariMethod = HT.methodGet,
            ariPayload = PayloadBS B.empty,
            ariPayloadHash = Nothing,
            ariPath = "v1/service",
            ariHeaders = [],
            ariQueryParams = []
          }
  
    let rspBS = NC.responseBody rsp
    case eitherDecode rspBS of
      Right ss -> return ss
      Left err -> throwIO $ MErrVJsonParse $ T.pack err
  
  -- | Send service restart or stop action to MinIO server.
  serviceSendAction :: ServiceAction -> Minio ()
  serviceSendAction action = do
    let payload = PayloadBS $ LBS.toStrict $ A.encode action
    void $
      executeAdminRequest
        AdminReqInfo
          { ariMethod = HT.methodPost,
            ariPayload = payload,
            ariPayloadHash = Nothing,
            ariPath = "v1/service",
            ariHeaders = [],
            ariQueryParams = []
          }
  
  -- | Get the current config file from server.
  getConfig :: Minio ByteString
  getConfig = do
    rsp <-
      executeAdminRequest
        AdminReqInfo
          { ariMethod = HT.methodGet,
            ariPayload = PayloadBS B.empty,
            ariPayloadHash = Nothing,
            ariPath = "v1/config",
            ariHeaders = [],
            ariQueryParams = []
          }
    return $ LBS.toStrict $ NC.responseBody rsp
  
  -- | Set a new config to the server.
  setConfig :: ByteString -> Minio SetConfigResult
  setConfig config = do
    rsp <-
      executeAdminRequest
        AdminReqInfo
          { ariMethod = HT.methodPut,
            ariPayload = PayloadBS config,
            ariPayloadHash = Nothing,
            ariPath = "v1/config",
            ariHeaders = [],
            ariQueryParams = []
          }
  
    let rspBS = NC.responseBody rsp
    case eitherDecode rspBS of
      Right scr -> return scr
      Left err -> throwIO $ MErrVJsonParse $ T.pack err
  
  -- | Get the progress of currently running heal task, this API should be
  -- invoked right after `startHeal`. `token` is obtained after `startHeal`
  -- which should be used to get the heal status.
  getHealStatus :: Maybe Bucket -> Maybe Text -> Text -> Minio HealStatus
  getHealStatus bucket prefix token = do
    when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath
    let qparams = HT.queryTextToQuery [("clientToken", Just token)]
    rsp <-
      executeAdminRequest
        AdminReqInfo
          { ariMethod = HT.methodPost,
            ariPayload = PayloadBS B.empty,
            ariPayloadHash = Nothing,
            ariPath = healPath bucket prefix,
            ariHeaders = [],
            ariQueryParams = qparams
          }
    let rspBS = NC.responseBody rsp
    case eitherDecode rspBS of
      Right hs -> return hs
      Left err -> throwIO $ MErrVJsonParse $ T.pack err
  
  doHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Bool -> Minio HealStartResp
  doHeal bucket prefix opts forceStart = do
    when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath
    let payload = PayloadBS $ LBS.toStrict $ A.encode opts
    let qparams =
          bool
            []
            (HT.queryTextToQuery [("forceStart", Just "true")])
            forceStart
  
    rsp <-
      executeAdminRequest
        AdminReqInfo
          { ariMethod = HT.methodPost,
            ariPayload = payload,
            ariPayloadHash = Nothing,
            ariPath = healPath bucket prefix,
            ariHeaders = [],
            ariQueryParams = qparams
          }
  
    let rspBS = NC.responseBody rsp
    case eitherDecode rspBS of
      Right hsr -> return hsr
      Left err -> throwIO $ MErrVJsonParse $ T.pack err
  
  -- | Start a heal sequence that scans data under given (possible empty)
  -- `bucket` and `prefix`. The `recursive` bool turns on recursive
  -- traversal under the given path. `dryRun` does not mutate on-disk data,
  -- but performs data validation. Two heal sequences on overlapping paths
  -- may not be initiated. The progress of a heal should be followed using
  -- the `HealStatus` API. The server accumulates results of the heal
  -- traversal and waits for the client to receive and acknowledge
  -- them using the status API
  startHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Minio HealStartResp
  startHeal bucket prefix opts = doHeal bucket prefix opts False
  
  -- | Similar to start a heal sequence, but force start a new heal sequence
  -- even if an active heal is under progress.
  forceStartHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Minio HealStartResp
  forceStartHeal bucket prefix opts = doHeal bucket prefix opts True
  
  -- | Fetches information for all cluster nodes, such as server
  -- properties, storage information, network statistics, etc.
  getServerInfo :: Minio [ServerInfo]
  getServerInfo = do
    rsp <-
      executeAdminRequest
        AdminReqInfo
          { ariMethod = HT.methodGet,
            ariPayload = PayloadBS B.empty,
            ariPayloadHash = Nothing,
            ariPath = "v1/info",
            ariHeaders = [],
            ariQueryParams = []
          }
    let rspBS = NC.responseBody rsp
    case eitherDecode rspBS of
      Right si -> return si
      Left err -> throwIO $ MErrVJsonParse $ T.pack err
  
  executeAdminRequest :: AdminReqInfo -> Minio (Response LByteString)
  executeAdminRequest ari = do
    req <- buildAdminRequest ari
    mgr <- asks mcConnManager
    httpLbs req mgr
  
  buildAdminRequest :: AdminReqInfo -> Minio NC.Request
  buildAdminRequest areq = do
    ci <- asks mcConnInfo
    sha256Hash <-
      if connectIsSecure ci
        then -- if secure connection
          return "UNSIGNED-PAYLOAD"
        else -- otherwise compute sha256
          getPayloadSHA256Hash (ariPayload areq)
  
    timeStamp <- liftIO getCurrentTime
  
    mgr <- asks mcConnManager
    cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr
  
    let hostHeader = (hHost, getHostAddr ci)
        newAreq =
          areq
            { ariPayloadHash = Just sha256Hash,
              ariHeaders =
                hostHeader
                  : sha256Header sha256Hash
                  : ariHeaders areq
            }
        signReq = toRequest ci newAreq
        sp =
          SignParams
            (coerce $ cvAccessKey cv)
            (coerce $ cvSecretKey cv)
            (coerce $ cvSessionToken cv)
            ServiceS3
            timeStamp
            Nothing
            Nothing
            (ariPayloadHash newAreq)
        signHeaders = signV4 sp signReq
  
    -- Update signReq with Authorization header containing v4 signature
    return
      signReq
        { NC.requestHeaders = ariHeaders newAreq ++ signHeaders
        }
    where
      toRequest :: ConnectInfo -> AdminReqInfo -> NC.Request
      toRequest ci aReq =
        NC.defaultRequest
          { NC.method = ariMethod aReq,
            NC.secure = connectIsSecure ci,
            NC.host = encodeUtf8 $ connectHost ci,
            NC.port = connectPort ci,
            NC.path = B.intercalate "/" [adminPath, ariPath aReq],
            NC.requestHeaders = ariHeaders aReq,
            NC.queryString = HT.renderQuery False $ ariQueryParams aReq,
            NC.requestBody = getRequestBody (ariPayload aReq)
          }
  