{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import           Data.Either               (rights)
import           Data.String               (IsString(..))
import           Prelude                   hiding (all)
import qualified Test.QuickCheck.Monadic   as QCM
import           Test.Tasty
import           Test.Tasty.HUnit
import           Test.Tasty.QuickCheck     (testProperty)

import           Control.Concurrent        (threadDelay)
import           Control.Lens              ((^.), (^?))
import           Control.Monad             (forM_)
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class (lift)
import qualified Data.Aeson                as JSON
import           Data.Aeson                ((.=))
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap         as KM
#endif
import           Data.Aeson.Lens           (key, _Array, _Null, _Object,
                                            _String, _Value)
import qualified Data.Aeson.Types          as JSON
import qualified Data.ByteString           as B
import qualified Data.ByteString.Char8     as C
import qualified Data.ByteString.Lazy      as BL
import qualified Data.HashMap.Strict       as HM
import           Data.Int                  (Int)
import qualified Data.Map                  as M
import           Data.Maybe                (fromJust, isJust, isNothing, listToMaybe)
import           Data.Monoid
import           Data.Text                 (Text, unpack)
import qualified Data.Vector               as V
import           Network.Connection        (TLSSettings (..))
import           Network.HTTP.Client       (newManager)
import           Network.HTTP.Client.TLS
import           Network.HTTP.Types.Status
import           System.Directory          (getCurrentDirectory)
import           System.Environment        (lookupEnv)
import           System.Process            (system)

import           Docker.Client

#if MIN_VERSION_lens_aeson(1,2,0)
emptyMap :: KM.KeyMap v
emptyMap = KM.empty
#else
emptyMap :: HM.HashMap k v
emptyMap = HM.empty
#endif

-- opts = defaultClientOpts
testImageName = "docker-hs/test"
imageToDeleteFullName = "hello-world:latest"

toStrict1 = B.concat . BL.toChunks

runDocker f
          -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}
          -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight
          -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
          -- let settings = mkManagerSettings (TLSSettings params) Nothing
          -- mgr <- newManager settings
 = do
  h <- unixHttpHandler "/var/run/docker.sock"
  runDockerT (defaultClientOpts, h) f

testDockerVersion :: IO ()
testDockerVersion =
  runDocker $
  do v <- getDockerVersion
     lift $ assert $ isRight v

testStopNonexisting :: IO ()
testStopNonexisting = runDocker $ do
    res <- stopContainer DefaultTimeout $ fromJust $ toContainerID "thisshouldnotexist"
    lift $ assert $ isLeft res

testFindImage :: IO ()
testFindImage =
  runDocker $
  do images <- listImages defaultListOpts >>= fromRight
     let xs = filter (elem imageFullName . imageRepoTags) images
     lift $ assert $ length xs == 1
  where
    imageFullName = testImageName <> ":latest"

testDeleteImage :: IO ()
testDeleteImage = runDocker $ do
  img <- fmap fromJust findTestImage
  result <- deleteImage defaultImageDeleteOpts (imageId img)
  lift $ assert $ isRight result
  maybeTestImageAfter <- findTestImage
  lift $ assert $ isNothing maybeTestImageAfter
  where
    findTestImage =
      do
        images <- listImages defaultListOpts >>= fromRight
        return $ listToMaybe
               $ filter (elem imageToDeleteFullName . imageRepoTags) images

testListContainers :: IO ()
testListContainers =
  runDocker $
  do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
     c <- fromRight containerId
     res <- listContainers $ ListOpts { all=True }
     deleteContainer (ContainerDeleteOpts True True) c
     lift $ assert $ isRight res

testBuildFromDockerfile :: IO ()
testBuildFromDockerfile = do
  cur <- getCurrentDirectory
  let ctxDir = cur ++ "/tests"
  runDocker $ do
    r <- buildImageFromDockerfile (defaultBuildOpts "docker-hs/dockerfile-test") ctxDir
    lift $ assert $ isRight r


testRunAndReadLog :: IO ()
testRunAndReadLog = testRunAndReadLogHelper $ NetworkingConfig HM.empty

testRunAndReadLogWithNetworking :: IO ()
testRunAndReadLogWithNetworking = testRunAndReadLogHelper $ NetworkingConfig $ HM.fromList [("test-network", EndpointConfig ["cellar-door"])]

testRunAndReadLogHelper :: NetworkingConfig -> IO ()
testRunAndReadLogHelper networkingConfig =
  runDocker $
  do let containerConfig = (defaultContainerConfig (testImageName <> ":latest")) {env = [EnvVar "TEST" "123"]}
     createdNetworks <- rights <$> mapM createNetworkWithName networkNames
     containerId <- createContainer (CreateOpts containerConfig defaultHostConfig networkingConfig) Nothing
     c <- fromRight containerId
     status1 <- startContainer defaultStartOpts c
     _ <- inspectContainer c >>= fromRight
     lift $ threadDelay 300000 -- give 300ms for the application to finish
     lift $ assertBool ("starting the container, unexpected status: " ++ show status1) $ isRightUnit status1
     logs <- getContainerLogs defaultLogOpts c >>= fromRight
     lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
     status3 <- deleteContainer (ContainerDeleteOpts True True) c
     lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3
     mapM_ removeNetwork createdNetworks
  where
    isRightUnit (Right ()) = True
    isRightUnit _          = False
    networkNames = HM.keys $ endpointsConfig networkingConfig
    createNetworkWithName name = createNetwork $
      (defaultCreateNetworkOpts name) { createNetworkCheckDuplicate = True }

testCreateRemoveNetwork :: IO ()
testCreateRemoveNetwork = do
  runDocker $ do
    createStatus <- createNetwork $ defaultCreateNetworkOpts "test-network"
    lift $ assertBool ("creating a network, unexpected status: " ++ show createStatus) $ isRight createStatus
    nid <- fromRight createStatus
    removeStatus <- removeNetwork nid
    lift $ assertBool ("removing a network, unexpected status: " ++ show removeStatus) $ isRight removeStatus

testLogDriverOptionsJson :: TestTree
testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]
  where
    test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1
    test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2
    test3 =
      testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
    sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
    sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
    key1 :: IsString a => a
    key1 = "some-key"
    val1 = "some-val"
    key2 :: IsString a => a
    key2 = "some-key2"
    val2 = "some-key2"

testExposedPortsJson :: TestTree
testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [testTCP, testUDP]
  where
    testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == emptyMap
    testUDP =
      testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == emptyMap
    sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]

testLabelsJson :: TestTree
testLabelsJson = testGroup "Testing Labels JSON" [testLS1, testLS2, testOverride]
  where
    testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1
    testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2
    testOverride =
      testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^.
      key key1 .
      _String ==
      "override"
    sampleLS = [Label key1 val1, Label key2 val2]
    key1 :: IsString a => a
    key1 = "com.example.some-label"
    val1 = "some-value"
    key2 :: IsString a => a
    key2 = "something"
    val2 = "value"

testVolumesJson :: TestTree
testVolumesJson = testGroup "Testing Volumes JSON" [testSample1, testSample2]
  where
    testSample1 =
      testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object ==
      emptyMap
    testSample2 =
      testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object ==
      emptyMap
    sampleVolumes = [Volume "/tmp", Volume "/opt"]

testBindsJson :: TestTree
testBindsJson = testGroup "Testing Binds JSON" [testSample1, testSample2, testSample3]
  where
    testSample1 =
      testCase "Testing Bind without VolumePermission" $
        JSON.String "/foo:/bar" @=? JSON.toJSON (Bind "/foo" "/bar" Nothing)
    testSample2 =
      testCase "Testing Bind with ReadOnly" $
        JSON.String "/foo:/bar:ro" @=? JSON.toJSON (Bind "/foo" "/bar" (Just ReadOnly))
    testSample3 =
      testCase "Testing Bind with WriteOnly" $
        JSON.String "/foo:/bar:rw" @=? JSON.toJSON (Bind "/foo" "/bar" (Just ReadWrite))

testPortBindingJSON :: TestTree
testPortBindingJSON = testGroup "Testing PortBinding JSON" [testSample1]
  where
    testSample1 =
      testCase "Test decoding null hostPorts" $ assert $ (JSON.decode "{ \"22/tcp\": null }" :: Maybe [PortBinding]) == Just [PortBinding 22 TCP []]


testEntrypointJson :: TestTree
testEntrypointJson = testGroup "Testing ContainerConfig JSON" [testSample1, testSample2, testSample3, testSample4, testSample5]
  where
    testSample1 =
      testCase "Test toJSON with empty entrypoint (null)" $ assert $ JSON.toJSON (Entrypoint []) ^. _Null == ()
    testSample2 =
      testCase "Test toJSON with entrypoint as Array" $ assert $
      JSON.toJSON (Entrypoint sampleEntrypointArr) ==
      JSON.toJSON sampleEntrypointArr
    testSample3 =
      testCase "Test decoding entrypoint as string" $ assert $ (JSON.decode "\"cmd\"") ==
      Just (Entrypoint ["cmd"])
    testSample4 =
      testCase "Test decoding as null" $ assert $ (JSON.decode "null" :: Maybe Entrypoint) ==
      Just (Entrypoint [])
    testSample5 =
      testCase "Test decoding as array" $ assert $ (JSON.decode (JSON.encode sampleEntrypointArr) :: Maybe Entrypoint) ==
      Just (Entrypoint sampleEntrypointArr)
    sampleEntrypointArr = ["cmd", "--some-flag", "--some-flag2"]

testEnvVarJson :: TestTree
testEnvVarJson = testGroup "Testing EnvVar JSON" [testSampleEncode, testSampleDecode]
  where
    testSampleEncode =
      testCase "Test toJSON" $ assert $ JSON.toJSON (EnvVar "cellar" "door") == JSON.String "cellar=door"
    testSampleDecode =
      testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==
        Just (EnvVar "cellar" "door")

testNetworkingConfigJson :: TestTree
testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSampleEncode]
  where
    testSampleEncode =
      let networkingConfig = NetworkingConfig $ HM.fromList [("custom-network", EndpointConfig ["cellar", "door"])]
       in testCase "Test toJSON" $ assert $ JSON.toJSON networkingConfig ==
        JSON.object
          [ "EndpointsConfig" .= JSON.object
            [ "custom-network" .= JSON.object
              [ "Aliases" .= (["cellar", "door"] :: [Text])
              ]
            ]
          ]

integrationTests :: TestTree
integrationTests =
  testGroup
    "Integration Tests"
    [ testCase "Get docker version" testDockerVersion
    , testCase "Build image from Dockerfile" testBuildFromDockerfile
    , testCase "Find image by name" testFindImage
    , testCase "Delete image" testDeleteImage
    , testCase "List containers" testListContainers
    , testCase "Run a dummy container and read its log" testRunAndReadLog
    , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking
    , testCase "Try to stop a container that doesn't exist" testStopNonexisting
    , testCase "Create and remove a network" testCreateRemoveNetwork
    ]

jsonTests :: TestTree
jsonTests =
  testGroup
    "JSON Tests"
    [ testExposedPortsJson
    , testVolumesJson
    , testBindsJson
    , testLabelsJson
    , testLogDriverOptionsJson
    , testPortBindingJSON
    , testEntrypointJson
    , testEnvVarJson
    , testNetworkingConfigJson
    ]

setup :: IO ()
setup =
  mapM_ system
        [ "docker pull " ++ unpack imageToDeleteFullName
        , "docker build -t " ++ unpack testImageName ++ " tests"
        ]

isLeft = not . isRight

isRight (Left _)  = False
isRight (Right _) = True

fromRight
  :: (MonadIO m, Show l)
  => Either l r -> m r
fromRight (Left l) = do
  liftIO $ assertFailure $ "Left: " ++ show l
  undefined
fromRight (Right r) = return r

main :: IO ()
main = do
  stackage  <- lookupEnv "RUN_INTEGRATION_TESTS"
  case  stackage of
    Nothing -> defaultMain $ testGroup "Tests" [jsonTests]
    Just _ -> do
      setup
      defaultMain $ testGroup "Tests" [jsonTests, integrationTests]