diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/docker.cabal b/docker.cabal --- a/docker.cabal +++ b/docker.cabal @@ -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 diff --git a/src/Docker/Client/Http.hs b/src/Docker/Client/Http.hs --- a/src/Docker/Client/Http.hs +++ b/src/Docker/Client/Http.hs @@ -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? diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -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 - diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -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] -