{-# LANGUAGE CPP                 #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ParallelListComp    #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import           Control.Monad
#if __GLASGOW_HASKELL__ <= 708
import           Control.Applicative
#endif
import qualified Data.Map as M
import qualified Data.Riak.Proto as Proto
import qualified Data.Set as S
import           Data.List.NonEmpty (NonEmpty(..))
#if __GLASGOW_HASKELL__ < 804
import           Data.Semigroup
#endif
import           Data.Text (Text)
import           Data.Function ((&))
import           Control.Concurrent (threadDelay)
import           Control.Exception
import           Lens.Micro ((^.), (.~))
import qualified Network.Riak as Riak
import           Network.Riak.Admin.DSL
import qualified Network.Riak.Basic as B
import qualified Network.Riak.Content as B (binary,RpbContent)
import           Network.Riak.Connection (exchange)
import qualified Network.Riak.CRDT as C
import qualified Network.Riak.CRDT.Riak as C
import qualified Network.Riak.Request as Req
import qualified Network.Riak.Response as Resp
import qualified Network.Riak.Search as S
import qualified Network.Riak.JSON as J
import           Network.Riak.Resolvable (ResolvableMonoid (..))
import           Network.Riak.Types
import qualified Properties
import qualified CRDTProperties as CRDT
import           Utils
import           Test.Tasty
import           Test.Tasty.HUnit

main :: IO ()
main = do
  setup
  defaultMain tests

setup :: IO ()
setup = do
  -- Create a "set-ix" index and wait for it to exist.
  let createIxUrl :: String
      createIxUrl = globalHost ++ ":" ++ show globalHttpPort ++ "/search/index/set-ix"

  shell ("curl -sf -XPUT " ++ createIxUrl ++ " -H 'Content-Type: application/json'")
  let loop =
        try (shell ("curl -sf " ++ createIxUrl)) >>= \case
          Left (_ :: ShellFailure) -> do
            threadDelay (1*1000*1000)
            loop
          Right _ -> pure ()
  loop

  riakAdminWith globalAdmin
    [ waitForService "riak_kv" Nothing
    , waitForService "yokozuna" Nothing

    , bucketTypeCreate "maps" (Just "'{\"props\":{\"datatype\":\"map\"}}'")
    , bucketTypeCreate "sets" (Just "'{\"props\":{\"datatype\":\"set\",\"search_index\":\"set-ix\"}}'")
    , bucketTypeCreate "counters" (Just "'{\"props\":{\"datatype\":\"counter\"}}'")

    , bucketTypeActivate "maps"
    , bucketTypeActivate "sets"
    , bucketTypeActivate "counters"

    , bucketTypeCreate "untyped-1" Nothing
    , bucketTypeCreate "untyped-2" Nothing

    , bucketTypeActivate "untyped-1"
    , bucketTypeActivate "untyped-2"
    ]

tests :: TestTree
tests = testGroup "Tests" [properties,
                           integrationalTests,
                           ping'o'death,
                           exceptions,
                           crdts,
                           searches,
                           bucketTypes
                          ]
properties :: TestTree
properties = testGroup "simple properties" Properties.tests

integrationalTests :: TestTree
integrationalTests = testGroup "integrational tests"
  [ testClusterSimple
#ifdef TEST2I
  , testIndexedPutGet
#endif
  ]

crdts :: TestTree
crdts = testGroup "CRDT" [
         testGroup "simple" [counter, set, map_],
         CRDT.tests
        ]

searches :: TestTree
searches = testGroup "Search" [
            search1,
            search2,
            getIndex,
            putIndex,
            deleteIndex
           ]

testClusterSimple :: TestTree
testClusterSimple = testCase "testClusterSimple" $ withGlobalConn B.ping


testIndexedPutGet :: TestTree
testIndexedPutGet = testCase "testIndexedPutGet" $ do
    let bt = Nothing
        b = "riak-haskell-client-test"
        k = "test"
    keys <- withGlobalConn $ \c -> do
      _ <- J.putIndexed c bt b k [(IndexInt "someindex" 135)] Nothing
          (RM (M.fromList [("somekey", "someval")] :: M.Map Text Text))
          Default Default
      Riak.getByIndex c b (IndexQueryExactInt "someindex" 135)
    assertEqual "" ["test"] keys

ping'o'death :: TestTree
ping'o'death = testCase "ping'o'death" $ replicateM_ 23 ping
    where ping = withGlobalConn (\c -> replicateM_ 1024 (Riak.ping c))


counter :: TestTree
counter = testCase "increment" $ withGlobalConn $ \conn -> do
              Just (C.DTCounter (C.Counter a)) <- act conn
              Just (C.DTCounter (C.Counter b)) <- act conn
              assertEqual "inc by 1" 1 (b-a)
    where
      act c = do C.counterSendUpdate c "counters" "xxx" "yyy" [C.CounterInc 1]
                 C.get c "counters" "xxx" "yyy"

set :: TestTree
set = testCase "set add" $ withGlobalConn $ \conn -> do
        C.setSendUpdate conn btype buck key [C.SetRemove val]
        C.setSendUpdate conn btype buck key [C.SetAdd val]
        Just (C.DTSet (C.Set r)) <- C.get conn btype buck key
        assertBool "-foo +foo => contains foo" $ val `S.member` r
    where
      (btype,buck,key,val) = ("sets","xxx","yyy","foo")

map_ :: TestTree
map_ = testCase "map update" $ withGlobalConn $ \conn -> do
         Just (C.DTMap a) <- act conn -- do smth (increment), get
         Just (C.DTMap b) <- act conn -- increment, get
         assertEqual "map update" (C.modify mapOp a) b -- modify's behaviour should match
         assertEqual "mapUpdate sugar" mapOp' mapOp

         -- remove top-level field (X)
         C.mapSendUpdate conn btype buck key [C.MapRemove fieldX]
         Just (C.DTMap c) <- act conn
         assertEqual "update after delete" (Just updateCreates) $ C.xlookup "X" C.MapMapTag c

         -- remove nested field (X/Y)
         C.mapSendUpdate conn btype buck key [C.MapUpdate (C.MapPath $ "X" :| [])
                                                   (C.MapMapOp (C.MapRemove fieldY))]
         Just (C.DTMap d) <- C.get conn btype buck key
         assertEqual "update after nested delete 1" Nothing
                         $ C.xlookup ("X" C.-/ "Y") C.MapMapTag d
         assertEqual "update after nested delete 2" (Just (C.MapMap (C.Map mempty)))
                         $ C.xlookup "X" C.MapMapTag d
    where
      act c = do C.mapSendUpdate c btype buck key [mapOp]
                 C.get c btype buck key

      btype = "maps"
      fieldX = C.MapField C.MapMapTag "X"
      fieldY = C.MapField C.MapMapTag "Y"
      (buck,key) = ("xxx","yyy")

      updateCreates = C.MapMap (C.Map (M.fromList
                                            [(C.MapField C.MapMapTag "Y",
                                              C.MapMap (C.Map (M.fromList
                                                                    [(C.MapField C.MapCounterTag "Z",
                                                                      C.MapCounter (C.Counter 1))])))]))

      mapOp = "X" C.-/ "Y" C.-/ "Z" `C.mapUpdate` C.CounterInc 1

      mapOp' = C.MapUpdate (C.MapPath ("X" :| "Y" : "Z" : []))
                           (C.MapCounterOp (C.CounterInc 1))


search1 :: TestTree
search1 = testCase "basic searchRaw" $ withGlobalConn $ \conn -> do
           C.sendModify conn btype buck key [C.SetRemove kw]
           delay
           a <- query conn ("set:" <> kw)
           assertEqual "should not found non-existing" (S.SearchResult [] (Just 0.0) (Just 0)) a
           C.sendModify conn btype buck key [C.SetAdd kw]
           delay
           b <- query conn ("set:" <> kw)
           assertBool "searches specific" $ not (null (S.docs b))
           c <- query conn ("set:*")
           assertBool "searches *" $ not (null (S.docs c))
    where
      query conn q = S.searchRaw conn q "set-ix"
      (btype,buck,key) = ("sets","xxx","yyy")
      kw = "haskell"
      delay = threadDelay (1*5000*1000) -- http://docs.basho.com/riak/2.1.3/dev/using/search/#Indexing-Values

search2 :: TestTree
search2 = testCase "search with fl" $ withGlobalConn $ \conn -> do
            let req = (Req.search "set:haskell" "set-ix") & Proto.fl .~ ["_yz_rk"]
            resp <- Resp.search <$> exchange conn req
            assertEqual "only returns fl"
              ([[("_yz_rk", Just "yyy")]])
              (S.docs resp)


getIndex :: TestTree
getIndex = testCase "getIndex" $ withGlobalConn $ \conn -> do
             all' <- S.getIndex conn Nothing
             one <- S.getIndex conn (Just "set-ix")
             assertBool "all indeces" $ not (null all')
             assertEqual "set index" 1 (length one)

putIndex :: TestTree
putIndex = testCase "putIndex" $ withGlobalConn $ \conn -> do
             _ <- S.putIndex conn (S.indexInfo "dummy-index" Nothing Nothing) Nothing
             threadDelay 5000000
             one <- S.getIndex conn (Just "dummy-index")
             assertEqual "index was created" 1 (length one)

deleteIndex :: TestTree
deleteIndex = testCase "deleteIndex" $ withGlobalConn $ \conn -> do
  S.deleteIndex conn "dummy-index"
  threadDelay (5*1000*1000)

  _ <- tryJust f (S.getIndex conn (Just "dummy-index"))
  pure ()

  where
    f :: Proto.RpbErrorResp -> Maybe ()
    f resp = guard (resp ^. Proto.errmsg == "notfound")

bucketTypes :: TestTree
bucketTypes = testCase "bucketTypes" $ withGlobalConn $ \conn -> do
             [p0,p1,p2] <- sequence [ B.put conn bt b k Nothing o Default Default
                                      | bt <- types | o <- [o0,o1,o2] ]
             [r0,r1,r2] <- sequence [ B.get conn bt b k Default | bt <- types ]

             assertBool "sound get Nothing"   (valok r0 o0)
             assertBool "sound get untyped-1" (valok r1 o1)
             assertBool "sound get untyped-2" (valok r2 o2)

             assertEqual "put=get Nothing"   (Just p0) r0
             assertEqual "put=get untyped-1" (Just p1) r1
             assertEqual "put=get untyped-2" (Just p2) r2
    where
      (b,k) = ("xxx","0") :: (Bucket,Key)
      types = [Nothing, Just "untyped-1", Just "untyped-2"] :: [Maybe BucketType]
      [o0,o1,o2] = B.binary <$> ["A","B","C"] :: [B.RpbContent]

      valok :: Maybe ([B.RpbContent], VClock) -> B.RpbContent -> Bool
      valok (Just (rs,_)) o = (o ^. Proto.value) `elem` map (^. Proto.value) rs
      valok _ _             = False


exceptions :: TestTree
exceptions = testGroup "exceptions" [
              testCase "correct put"  . shouldBeOK . withGlobalConn $ put,
              testCase "correct put_" . shouldBeOK . withGlobalConn $ put_,
              testCase "invalid put"  . shouldThrow . withGlobalConn $ putErr,
              testCase "invalid put_" . shouldThrow . withGlobalConn $ put_Err
             ]
    where
      put     = putSome B.put  btype
      put_    = putSome B.put_ btype
      putErr  = putSome B.put  noBtype
      put_Err = putSome B.put_ noBtype

      putSome :: (Connection -> Maybe BucketType -> Bucket -> Key
                             -> Maybe VClock -> B.RpbContent -> Quorum -> Quorum -> IO a)
              -> Maybe BucketType -> Connection -> IO a
      putSome f bt c = f c bt buck key Nothing val Default Default

      shouldBeOK act  = act >> assertBool "ok" True
      shouldThrow act = catch (act >> assertBool "exception" False) (\(_e::Proto.RpbErrorResp) -> pure ())

      btype   = Just "untyped-1"
      noBtype = Just "no such type"
      buck = "xxx"
      key = "0"
      val = B.binary ""