{-# LANGUAGE OverloadedStrings #-}
# LANGUAGE RecordWildCards #

module Test.Snapshots (spec) where

import qualified Data.Aeson.KeyMap as X
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Network.HTTP.Types.Method as NHTM
import qualified Network.URI as URI
import Test.Common
import Test.Generators ()
import Test.Import

spec :: Spec
spec = do
  describe "FsSnapshotRepo" $
    prop "SnapshotRepo laws" $ \fsr ->
      fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)

  describe "Snapshot repos" $ do
    it "always parses all snapshot repos API" $
      when' canSnapshot $
        withTestEnv $ do
          res <- getSnapshotRepos AllSnapshotRepos
          liftIO $ case res of
            Left e -> expectationFailure ("Expected a right but got Left " <> show e)
            Right _ -> return ()

    it "finds an existing list of repos" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          let r2n = SnapshotRepoName "bloodhound-repo2"
          withSnapshotRepo r1n $ \r1 ->
            withSnapshotRepo r2n $ \r2 -> do
              repos <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n]))
              liftIO $ case repos of
                Right xs -> do
                  let srt = L.sortOn gSnapshotRepoName
                  srt xs `shouldBe` srt [r1, r2]
                Left e -> expectationFailure (show e)

    it "creates and updates with updateSnapshotRepo" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \r1 -> do
            let Just (String dir) = X.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1))
            let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing
            resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression
            liftIO (validateStatus resp 200)
            Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| []))
            liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)

  verify came around in 1.4 it seems
    it "can verify existing repos" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \_ -> do
            res <- verifySnapshotRepo r1n
            liftIO $ case res of
              Right (SnapshotVerification vs)
                | null vs -> expectationFailure "Expected nonempty set of verifying nodes"
                | otherwise -> return ()
              Left e -> expectationFailure (show e)

  describe "Snapshots" $ do
    it "always parses all snapshots API" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \_ -> do
            res <- getSnapshots r1n AllSnapshots
            liftIO $ case res of
              Left e -> expectationFailure ("Expected a right but got Left " <> show e)
              Right _ -> return ()

    it "can parse a snapshot that it created" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \_ -> do
            let s1n = SnapshotName "example-snapshot"
            withSnapshot r1n s1n $ do
              res <- getSnapshots r1n (SnapshotList (ExactSnap s1n :| []))
              liftIO $ case res of
                Right [snap]
                  | snapInfoState snap == SnapshotSuccess
                      && snapInfoName snap == s1n ->
                      return ()
                  | otherwise -> expectationFailure (show snap)
                Right [] -> expectationFailure "There were no snapshots"
                Right snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps))
                Left e -> expectationFailure (show e)

  describe "Snapshot restore" $ do
    it "can restore a snapshot that we create" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \_ -> do
            let s1n = SnapshotName "example-snapshot"
            withSnapshot r1n s1n $ do
              let settings = defaultSnapshotRestoreSettings {snapRestoreWaitForCompletion = True}
              -- have to close an index to restore it
              resp1 <- closeIndex testIndex
              liftIO (validateStatus resp1 200)
              resp2 <- restoreSnapshot r1n s1n settings
              liftIO (validateStatus resp2 200)

    it "can restore and rename" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \_ -> do
            let s1n = SnapshotName "example-snapshot"
            withSnapshot r1n s1n $ do
              let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)"
              let replace = RRTLit "restored-" :| [RRSubWholeMatch]
              let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1"
              let overrides = RestoreIndexSettings {restoreOverrideReplicas = Just (ReplicaCount 0)}
              let settings =
                    defaultSnapshotRestoreSettings
                      { snapRestoreWaitForCompletion = True,
                        snapRestoreRenamePattern = Just pat,
                        snapRestoreRenameReplacement = Just replace,
                        snapRestoreIndexSettingsOverrides = Just overrides
                      }
              -- have to close an index to restore it
              let go = do
                    resp <- restoreSnapshot r1n s1n settings
                    liftIO (validateStatus resp 200)
                    exists <- indexExists expectedIndex
                    liftIO (exists `shouldBe` True)
              go `finally` deleteIndex expectedIndex

-- | Get configured repo paths for snapshotting. Note that by default
-- this is not enabled and if we are over es 1.5, we won't be able to
-- test snapshotting. Note that this can and should be part of the
-- client functionality in a much less ad-hoc incarnation.
getRepoPaths :: IO [FilePath]
getRepoPaths = withTestEnv $ do
  bhe <- getBHEnv
  let Server s = bhServer bhe
  let tUrl = s <> "/" <> "_nodes"
  initReq <- parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack tUrl))
  let req = setRequestIgnoreStatus $ initReq {method = NHTM.methodGet}
  Right (Object o) <- parseEsResponse . BHResponse =<< liftIO (httpLbs req (bhManager bhe))
  return $
    fromMaybe mempty $ do
      Object nodes <- X.lookup "nodes" o
      Object firstNode <- snd <$> headMay (X.toList nodes)
      Object settings <- X.lookup "settings" firstNode
      Object path <- X.lookup "path" settings
      Array repo <- X.lookup "repo" path
      return [T.unpack t | String t <- V.toList repo]

-- | 1.5 and earlier don't care about repo paths
canSnapshot :: IO Bool
canSnapshot = do
  repoPaths <- getRepoPaths
  return (not (null repoPaths))

withSnapshotRepo ::
  ( MonadMask m,
    MonadBH m
  ) =>
  SnapshotRepoName ->
  (GenericSnapshotRepo -> m a) ->
  m a
withSnapshotRepo srn@(SnapshotRepoName n) f = do
  repoPaths <- liftIO getRepoPaths
  we 'll use the first repo path if available , otherwise system temp
  dir . Note that this will fail on ES > 1.6 , so be sure you use
  -- @when' canSnapshot@.
  case repoPaths of
    (firstRepoPath : _) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f
    [] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f
  where
    alloc dir = do
      liftIO (setFileMode dir mode)
      let repo = FsSnapshotRepo srn "bloodhound-tests-backups" True Nothing Nothing Nothing
      resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo
      liftIO (validateStatus resp 200)
      return (toGSnapshotRepo repo)
    mode = ownerModes `unionFileModes` groupModes `unionFileModes` otherModes
    free GenericSnapshotRepo {..} = do
      resp <- deleteSnapshotRepo gSnapshotRepoName
      liftIO (validateStatus resp 200)

withSnapshot ::
  ( MonadMask m,
    MonadBH m
  ) =>
  SnapshotRepoName ->
  SnapshotName ->
  m a ->
  m a
withSnapshot srn sn = bracket_ alloc free
  where
    alloc = do
      resp <- createSnapshot srn sn createSettings
      liftIO (validateStatus resp 200)
    -- We'll make this synchronous for testing purposes
    createSettings =
      defaultSnapshotCreateSettings
        { snapWaitForCompletion = True,
          snapIndices = Just (IndexList (testIndex :| []))
          -- We don't actually need to back up any data
        }
    free =
      deleteSnapshot srn sn

# LANGUAGE OverloadedStrings #
 have to close an index to restore it
 have to close an index to restore it
 | Get configured repo paths for snapshotting. Note that by default
 this is not enabled and if we are over es 1.5, we won't be able to
 test snapshotting. Note that this can and should be part of the
 client functionality in a much less ad-hoc incarnation.
 | 1.5 and earlier don't care about repo paths
 @when' canSnapshot@.
 We'll make this synchronous for testing purposes
 We don't actually need to back up any data
# LANGUAGE RecordWildCards #

module Test.Snapshots (spec) where

import qualified Data.Aeson.KeyMap as X
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Network.HTTP.Types.Method as NHTM
import qualified Network.URI as URI
import Test.Common
import Test.Generators ()
import Test.Import

spec :: Spec
spec = do
  describe "FsSnapshotRepo" $
    prop "SnapshotRepo laws" $ \fsr ->
      fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)

  describe "Snapshot repos" $ do
    it "always parses all snapshot repos API" $
      when' canSnapshot $
        withTestEnv $ do
          res <- getSnapshotRepos AllSnapshotRepos
          liftIO $ case res of
            Left e -> expectationFailure ("Expected a right but got Left " <> show e)
            Right _ -> return ()

    it "finds an existing list of repos" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          let r2n = SnapshotRepoName "bloodhound-repo2"
          withSnapshotRepo r1n $ \r1 ->
            withSnapshotRepo r2n $ \r2 -> do
              repos <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n]))
              liftIO $ case repos of
                Right xs -> do
                  let srt = L.sortOn gSnapshotRepoName
                  srt xs `shouldBe` srt [r1, r2]
                Left e -> expectationFailure (show e)

    it "creates and updates with updateSnapshotRepo" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \r1 -> do
            let Just (String dir) = X.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1))
            let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing
            resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression
            liftIO (validateStatus resp 200)
            Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| []))
            liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)

  verify came around in 1.4 it seems
    it "can verify existing repos" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \_ -> do
            res <- verifySnapshotRepo r1n
            liftIO $ case res of
              Right (SnapshotVerification vs)
                | null vs -> expectationFailure "Expected nonempty set of verifying nodes"
                | otherwise -> return ()
              Left e -> expectationFailure (show e)

  describe "Snapshots" $ do
    it "always parses all snapshots API" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \_ -> do
            res <- getSnapshots r1n AllSnapshots
            liftIO $ case res of
              Left e -> expectationFailure ("Expected a right but got Left " <> show e)
              Right _ -> return ()

    it "can parse a snapshot that it created" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \_ -> do
            let s1n = SnapshotName "example-snapshot"
            withSnapshot r1n s1n $ do
              res <- getSnapshots r1n (SnapshotList (ExactSnap s1n :| []))
              liftIO $ case res of
                Right [snap]
                  | snapInfoState snap == SnapshotSuccess
                      && snapInfoName snap == s1n ->
                      return ()
                  | otherwise -> expectationFailure (show snap)
                Right [] -> expectationFailure "There were no snapshots"
                Right snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps))
                Left e -> expectationFailure (show e)

  describe "Snapshot restore" $ do
    it "can restore a snapshot that we create" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \_ -> do
            let s1n = SnapshotName "example-snapshot"
            withSnapshot r1n s1n $ do
              let settings = defaultSnapshotRestoreSettings {snapRestoreWaitForCompletion = True}
              resp1 <- closeIndex testIndex
              liftIO (validateStatus resp1 200)
              resp2 <- restoreSnapshot r1n s1n settings
              liftIO (validateStatus resp2 200)

    it "can restore and rename" $
      when' canSnapshot $
        withTestEnv $ do
          let r1n = SnapshotRepoName "bloodhound-repo1"
          withSnapshotRepo r1n $ \_ -> do
            let s1n = SnapshotName "example-snapshot"
            withSnapshot r1n s1n $ do
              let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)"
              let replace = RRTLit "restored-" :| [RRSubWholeMatch]
              let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1"
              let overrides = RestoreIndexSettings {restoreOverrideReplicas = Just (ReplicaCount 0)}
              let settings =
                    defaultSnapshotRestoreSettings
                      { snapRestoreWaitForCompletion = True,
                        snapRestoreRenamePattern = Just pat,
                        snapRestoreRenameReplacement = Just replace,
                        snapRestoreIndexSettingsOverrides = Just overrides
                      }
              let go = do
                    resp <- restoreSnapshot r1n s1n settings
                    liftIO (validateStatus resp 200)
                    exists <- indexExists expectedIndex
                    liftIO (exists `shouldBe` True)
              go `finally` deleteIndex expectedIndex

getRepoPaths :: IO [FilePath]
getRepoPaths = withTestEnv $ do
  bhe <- getBHEnv
  let Server s = bhServer bhe
  let tUrl = s <> "/" <> "_nodes"
  initReq <- parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack tUrl))
  let req = setRequestIgnoreStatus $ initReq {method = NHTM.methodGet}
  Right (Object o) <- parseEsResponse . BHResponse =<< liftIO (httpLbs req (bhManager bhe))
  return $
    fromMaybe mempty $ do
      Object nodes <- X.lookup "nodes" o
      Object firstNode <- snd <$> headMay (X.toList nodes)
      Object settings <- X.lookup "settings" firstNode
      Object path <- X.lookup "path" settings
      Array repo <- X.lookup "repo" path
      return [T.unpack t | String t <- V.toList repo]

canSnapshot :: IO Bool
canSnapshot = do
  repoPaths <- getRepoPaths
  return (not (null repoPaths))

withSnapshotRepo ::
  ( MonadMask m,
    MonadBH m
  ) =>
  SnapshotRepoName ->
  (GenericSnapshotRepo -> m a) ->
  m a
withSnapshotRepo srn@(SnapshotRepoName n) f = do
  repoPaths <- liftIO getRepoPaths
  we 'll use the first repo path if available , otherwise system temp
  dir . Note that this will fail on ES > 1.6 , so be sure you use
  case repoPaths of
    (firstRepoPath : _) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f
    [] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f
  where
    alloc dir = do
      liftIO (setFileMode dir mode)
      let repo = FsSnapshotRepo srn "bloodhound-tests-backups" True Nothing Nothing Nothing
      resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo
      liftIO (validateStatus resp 200)
      return (toGSnapshotRepo repo)
    mode = ownerModes `unionFileModes` groupModes `unionFileModes` otherModes
    free GenericSnapshotRepo {..} = do
      resp <- deleteSnapshotRepo gSnapshotRepoName
      liftIO (validateStatus resp 200)

withSnapshot ::
  ( MonadMask m,
    MonadBH m
  ) =>
  SnapshotRepoName ->
  SnapshotName ->
  m a ->
  m a
withSnapshot srn sn = bracket_ alloc free
  where
    alloc = do
      resp <- createSnapshot srn sn createSettings
      liftIO (validateStatus resp 200)
    createSettings =
      defaultSnapshotCreateSettings
        { snapWaitForCompletion = True,
          snapIndices = Just (IndexList (testIndex :| []))
        }
    free =
      deleteSnapshot srn sn
