--
-- MinIO Haskell SDK, (C) 2018 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.Data
import Network.Minio.Errors
import Network.Minio.Sign.V4
import Network.Minio.Utils

data DriveInfo = DriveInfo
  { diUuid :: Text,
    diEndpoint :: Text,
    diState :: Text
  }
  deriving (Eq, Show)

instance FromJSON DriveInfo where
  parseJSON = withObject "DriveInfo" $ \v ->
    DriveInfo
      <$> v .: "uuid"
      <*> v .: "endpoint"
      <*> v .: "state"

data StorageClass = StorageClass
  { scParity :: Int,
    scData :: Int
  }
  deriving (Eq, Show)

data ErasureInfo = ErasureInfo
  { eiOnlineDisks :: Int,
    eiOfflineDisks :: Int,
    eiStandard :: StorageClass,
    eiReducedRedundancy :: StorageClass,
    eiSets :: [[DriveInfo]]
  }
  deriving (Eq, Show)

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 (Eq, Show)

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 (Eq, Show)

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 (Eq, Show)

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 (Eq, Show)

instance FromJSON StorageInfo where
  parseJSON = withObject "StorageInfo" $ \v ->
    StorageInfo
      <$> v .: "Used"
      <*> v .: "Backend"

data CountNAvgTime = CountNAvgTime
  { caCount :: Int64,
    caAvgDuration :: Text
  }
  deriving (Eq, Show)

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 (Eq, Show)

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 (Eq, Show)

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 (Eq, Show)

instance FromJSON ServerInfo where
  parseJSON = withObject "ServerInfo" $ \v ->
    ServerInfo
      <$> v .: "error"
      <*> v .: "addr"
      <*> v .: "data"

data ServerVersion = ServerVersion
  { svVersion :: Text,
    svCommitId :: Text
  }
  deriving (Eq, Show)

instance FromJSON ServerVersion where
  parseJSON = withObject "ServerVersion" $ \v ->
    ServerVersion
      <$> v .: "version"
      <*> v .: "commitID"

data ServiceStatus = ServiceStatus
  { ssVersion :: ServerVersion,
    ssUptime :: NominalDiffTime
  }
  deriving (Eq, Show)

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 (Eq, Show)

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 (Eq, Show)

instance FromJSON HealStartResp where
  parseJSON = withObject "HealStartResp" $ \v ->
    HealStartResp
      <$> v .: "clientToken"
      <*> v .: "clientAddress"
      <*> v .: "startTime"

data HealOpts = HealOpts
  { hoRecursive :: Bool,
    hoDryRun :: Bool
  }
  deriving (Eq, Show)

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 (Eq, Show)

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 (Eq, Show)

instance FromJSON NodeSummary where
  parseJSON = withObject "NodeSummary" $ \v ->
    NodeSummary
      <$> v .: "name"
      <*> v .: "errSet"
      <*> v .: "errMsg"

data SetConfigResult = SetConfigResult
  { scrStatus :: Bool,
    scrNodeSummary :: [NodeSummary]
  }
  deriving (Eq, Show)

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 (Eq, Show)

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 (Eq, Show)

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/"

-- | 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 ->
          -- if secure connection
          return "UNSIGNED-PAYLOAD"
        -- otherwise compute sha256
        | otherwise -> getPayloadSHA256Hash (ariPayload areq)

  timeStamp <- liftIO getCurrentTime

  let hostHeader = (hHost, getHostAddr ci)
      newAreq =
        areq
          { ariPayloadHash = Just sha256Hash,
            ariHeaders =
              hostHeader
                : sha256Header sha256Hash
                : ariHeaders areq
          }
      signReq = toRequest ci newAreq
      sp =
        SignParams
          (connectAccessKey ci)
          (connectSecretKey ci)
          timeStamp
          Nothing
          Nothing
          (ariPayloadHash newAreq)
      signHeaders = signV4 sp signReq

  -- Update signReq with Authorization header containing v4 signature
  return
    signReq
      { NC.requestHeaders = ariHeaders newAreq ++ mkHeaderFromPairs 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)
        }