docker 0.4.0.0 → 0.4.0.1

raw patch · 5 files changed

+154/−88 lines, 5 filesdep +vectorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: vector

API changes (from Hackage documentation)

Files

• README.md +1/−1
• docker.cabal +3/−1
• src/Docker/Client/Http.hs +3/−3
• src/Docker/Client/Types.hs +23/−6
• tests/tests.hs +124/−77

@@ -9,7 +9,7 @@  **API is still not stable.** -Supported Docker Engine Api version: `v1.24`+Supported Docker Engine Api version: `v1.24` and onwards.  Anything upward of that should work since Docker versions their API. Older docker version and engine api versions are not supported at the moment.

@@ -1,5 +1,5 @@ name:                docker-version:             0.4.0.0+version:             0.4.0.1 synopsis:            An API client for docker written in Haskell description:         See API documentation below. homepage:            https://github.com/denibertovic/docker-hs@@ -27,6 +27,7 @@                      , data-default-class >= 0.0.1 && < 0.2.0                      , http-client >= 0.4.0 && < 0.5.0                      , http-types >= 0.9 && < 0.10.0+                     , vector                      , conduit                      , conduit-combinators                      , conduit-extra@@ -76,6 +77,7 @@                        , transformers                        , QuickCheck                        , process+                       , vector     type:                exitcode-stdio-1.0     main-is:             tests.hs     hs-source-dirs:      tests

@@ -17,7 +17,7 @@ import           Data.X509.File               (readKeyFile, readSignedObject) import           Network.HTTP.Client          (defaultManagerSettings,                                                managerRawConnection, method,-                                               newManager, parseUrl,+                                               newManager, parseRequest,                                                requestBody, requestHeaders) import qualified Network.HTTP.Client          as HTTP import           Network.HTTP.Client.Internal (makeConnection)@@ -94,7 +94,7 @@ mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request mkHttpRequest verb e opts = request         where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint (apiVer opts) e)-              initialR = parseUrl fullE+              initialR = parseRequest fullE               request' = case  initialR of                             Just ir ->                                 return $ ir {method = (encodeUtf8 . T.pack $ show verb),@@ -137,7 +137,7 @@       S.connect s (S.SockAddrUnix filePath)       makeConnection (SBS.recv s 8096)                      (SBS.sendAll s)-                     (S.sClose s)+                     (S.close s)  -- TODO: --  Move this to http-client-tls or network?

@@ -28,6 +28,7 @@     , Label(..)     , Tag     , Image(..)+    , Entrypoint(..)     , dropImagePrefix     , CreateOpts(..)     , BuildOpts(..)@@ -102,6 +103,7 @@ import           Data.Text           (Text) import qualified Data.Text           as T import           Data.Time.Clock     (UTCTime)+import qualified Data.Vector         as V import           GHC.Generics        (Generic) import           Prelude             hiding (all, tail) import           Text.Read           (readMaybe)@@ -643,7 +645,7 @@                      , cmd=[]                      , volumes=[]                      , workingDir=Nothing-                     , entrypoint=Nothing+                     , entrypoint=Entrypoint []                      , networkDisabled=Nothing                      , macAddress=Nothing                      , labels=[]@@ -696,7 +698,7 @@                         , memory=Nothing                         , memoryReservation=Nothing                         , memorySwap=Nothing-                        , oomKillDisable=False+                        , oomKillDisable=Just False                         , ulimits=[]                         } @@ -1308,7 +1310,7 @@                         , memoryReservation    :: Maybe MemoryConstraint                         , memorySwap           :: Maybe MemoryConstraint                         -- , memorySwappiness  :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.-                        , oomKillDisable       :: Bool+                        , oomKillDisable       :: Maybe Bool                         -- , pidsLimit         :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.                         , ulimits              :: [Ulimit]                         -- TODO: Missing from 1.24@@ -1386,6 +1388,21 @@         where key (ExposedPort p t) = show p <> slash <> show t               slash = T.unpack "/" +data Entrypoint = Entrypoint [T.Text] deriving (Eq, Show, Generic)++instance ToJSON Entrypoint where+    toJSON (Entrypoint (e:es)) = toJSON (e:es)+    toJSON (Entrypoint [])     = JSON.Null++instance FromJSON Entrypoint where+    parseJSON (JSON.String e) = return $ Entrypoint [e]+    parseJSON (JSON.Array ar) = do+      arr <- mapM parseJSON (V.toList ar)+      return $ Entrypoint arr+    parseJSON JSON.Null       = return $ Entrypoint []+    parseJSON _ = fail "Failed to parse Entrypoint"++ data ContainerConfig = ContainerConfig {                        hostname        :: Maybe Text                      , domainname      :: Maybe Text@@ -1404,7 +1421,7 @@                      , image           :: Text                      , volumes         :: [Volume]                      , workingDir      :: Maybe FilePath-                     , entrypoint      :: Maybe Text -- Can be null?+                     , entrypoint      :: Entrypoint                      , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?                      , macAddress      :: Maybe Text                      -- , onBuild         :: Maybe Text -- For 1.24, only see this in the inspect response.@@ -1412,6 +1429,7 @@                      , stopSignal      :: Signal                      } deriving (Eq, Show, Generic) + instance ToJSON ContainerConfig where     toJSON = genericToJSON defaultOptions {          fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}@@ -1433,7 +1451,7 @@         image <- o .: "Image"         volumes <- o .: "Volumes"         workingDir <- o .:? "WorkingDir"-        entrypoint <- o .:? "Entrypoint"+        entrypoint <- o .: "Entrypoint"         networkDisabled <- o .:? "networkDisabled"         macAddress <- o .:? "MacAddress"         labels <- o .:? "Labels" .!= []@@ -1464,4 +1482,3 @@ -- | Helper function that return an empty dictionary "{}" emptyJsonObject :: JSON.Value emptyJsonObject = JSON.Object HM.empty-

@@ -12,7 +12,8 @@ import           Control.Monad.IO.Class import           Control.Monad.Trans.Class (lift) import qualified Data.Aeson                as JSON-import           Data.Aeson.Lens           (key, _Object, _String, _Value)+import           Data.Aeson.Lens           (key, _Array, _Null, _Object,+                                            _String, _Value) import qualified Data.ByteString           as B import qualified Data.ByteString.Char8     as C import qualified Data.ByteString.Lazy      as BL@@ -22,6 +23,7 @@ import           Data.Maybe                (fromJust, isJust) 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@@ -31,113 +33,158 @@ import           Docker.Client  -- opts = defaultClientOpts- testImageName = "docker-hs-test"  toStrict1 = B.concat . BL.toChunks -runDocker f = do-    -- 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-    h <- defaultHttpHandler-    runDockerT (defaultClientOpts, h) f+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 <- defaultHttpHandler+  runDockerT (defaultClientOpts, h) f  testDockerVersion :: IO ()-testDockerVersion = runDocker $ do-    v <- getDockerVersion-    lift $ assert $ isRight v+testDockerVersion =+  runDocker $+  do v <- getDockerVersion+     lift $ assert $ isRight v  testFindImage :: IO ()-testFindImage = runDocker $ do-        images <- listImages defaultListOpts >>= fromRight-        let xs = filter ((== [imageFullName]) . imageRepoTags) images-        lift $ assert $ length xs == 1-    where imageFullName = testImageName <> ":latest"+testFindImage =+  runDocker $+  do images <- listImages defaultListOpts >>= fromRight+     let xs = filter ((== [imageFullName]) . imageRepoTags) images+     lift $ assert $ length xs == 1+  where+    imageFullName = testImageName <> ":latest"  testRunAndReadLog :: IO ()-testRunAndReadLog = runDocker $ do-    containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing-    c <- fromRight containerId-    status1 <- startContainer defaultStartOpts c-    _ <- inspectContainer c >>= fromRight-    lift $ threadDelay 300000 -- give 300ms for the application to finish-    lift $ assert $ isRightUnit status1-    status2 <- killContainer SIGTERM c-    logs <- getContainerLogs defaultLogOpts c >>= fromRight-    lift $ assert $ isRightUnit status2-    lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)-    status3 <- deleteContainer (DeleteOpts True True) c-    lift $ assert $ isRightUnit status3--    where-        isRightUnit (Right ()) = True-        isRightUnit _ = False+testRunAndReadLog =+  runDocker $+  do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing+     c <- fromRight containerId+     status1 <- startContainer defaultStartOpts c+     _ <- inspectContainer c >>= fromRight+     lift $ threadDelay 300000 -- give 300ms for the application to finish+     lift $ assert $ isRightUnit status1+     status2 <- killContainer SIGTERM c+     logs <- getContainerLogs defaultLogOpts c >>= fromRight+     lift $ assert $ isRightUnit status2+     lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)+     status3 <- deleteContainer (DeleteOpts True True) c+     lift $ assert $ isRightUnit status3+  where+    isRightUnit (Right ()) = True+    isRightUnit _          = False  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 = "some-key"-  val1 = "some-val"-  key2 = "some-key2"-  val2 = "some-key2"+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 = "some-key"+    val1 = "some-val"+    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 ==  HM.empty-  testUDP = testCase "udp port" $ assert $ JSON.toJSON  sampleEP ^. key "1337/tcp" . _Object == HM.empty-  sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]+testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [testTCP, testUDP]+  where+    testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty+    testUDP =+      testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty+    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 = "com.example.some-label"-  val1 = "some-value"-  key2 = "something"-  val2 = "value"+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 = "com.example.some-label"+    val1 = "some-value"+    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 ==  HM.empty-  testSample2 = testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON  sampleVolumes ^. key "/opt" . _Object ==  HM.empty-  sampleVolumes = [Volume "/tmp", Volume "/opt"]+testVolumesJson = testGroup "Testing Volumes JSON" [testSample1, testSample2]+  where+    testSample1 =+      testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object ==+      HM.empty+    testSample2 =+      testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object ==+      HM.empty+    sampleVolumes = [Volume "/tmp", Volume "/opt"] +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"]+ integrationTests :: TestTree-integrationTests = testGroup "Integration Tests" [-    testCase "Get docker version" testDockerVersion,-    testCase "Find image by name" testFindImage,-    testCase "Run a dummy container and read its log" testRunAndReadLog]+integrationTests =+  testGroup+    "Integration Tests"+    [ testCase "Get docker version" testDockerVersion+    , testCase "Find image by name" testFindImage+    , testCase "Run a dummy container and read its log" testRunAndReadLog+    ]  jsonTests :: TestTree-jsonTests = testGroup "JSON Tests" [testExposedPortsJson, testVolumesJson, testLabelsJson, testLogDriverOptionsJson]+jsonTests =+  testGroup+    "JSON Tests"+    [ testExposedPortsJson+    , testVolumesJson+    , testLabelsJson+    , testLogDriverOptionsJson+    , testEntrypointJson+    ]  setup :: IO ()-setup =  system ("docker build -t "++unpack testImageName++" tests") >> return ()+setup = system ("docker build -t " ++ unpack testImageName ++ " tests") >> return () -isRight (Left _) = False+isRight (Left _)  = False isRight (Right _) = True -fromRight :: (MonadIO m, Show l) => Either l r -> m r+fromRight+  :: (MonadIO m, Show l)+  => Either l r -> m r fromRight (Left l) = do-    liftIO $ assertFailure $ "Left: " ++ show l-    undefined+  liftIO $ assertFailure $ "Left: " ++ show l+  undefined fromRight (Right r) = return r  main :: IO () main = do   setup   defaultMain $ testGroup "Tests" [jsonTests, integrationTests]-