diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,18 +12,37 @@ Anything upward of that should work since Docker versions their API. Older docker version and engine api versions are not supported at the moment. +## Documentation + +The API-documentation is available at +[Hackage](https://hackage.haskell.org/package/docker). There are also some +usage-examples in the main library source file, +[`Client.hs`](https://hackage.haskell.org/package/docker/docs/Docker-Client.html). + ## Contributing -If you wish to contribute please see any issue tagged with "help wanted". -Make sure to submit your PR's against the `master` branch. +Please see [CONTRIBUTING.md](CONTRIBUTING.md). -Please consider filling an Issue first and discuss design decisions and implementation details before -writing any code. This is so that no development cycles go to waste on implementing a feature that -might not get merged either because of implementation details or other reasons. +### Project Setup +For working on the library, you need the Haskell Tool Stack installed (see [the +Haskell Tool Stack +website](https://docs.haskellstack.org/en/stable/install_and_upgrade/)). You +also need `make` to use the `Makefile` included in the project. Run `make help` +to see the available commands (for building, running the tests and releasing). +### Tests + +Tests are located in the `tests` directory and can be run with `make test`. This +only runs the unit tests. + +To run integration tests, you need Docker installed and listening on Port `2375` +of `localhost` (docker only listens to a Unix socket by default, see the [Docker +documentation](https://docs.docker.com/engine/reference/commandline/dockerd/#daemon-socket-option) +for details). Set the environment variable `RUN_INTEGRATION_TESTS`, i.e. +`RUN_INTEGRATION_TESTS=1 make test`. + ## IRC If you have any questions or suggestions you can find the maintainers in `#docker-haskell` on freenode. - diff --git a/docker.cabal b/docker.cabal --- a/docker.cabal +++ b/docker.cabal @@ -1,5 +1,5 @@ name: docker -version: 0.4.1.1 +version: 0.5.0.0 synopsis: An API client for docker written in Haskell description: See API documentation below. homepage: https://github.com/denibertovic/docker-hs @@ -26,7 +26,7 @@ , containers >= 0.5.0 && < 0.6.0 , data-default-class >= 0.0.1 && < 0.2.0 , http-client >= 0.4.0 && < 0.6.0 - , http-types >= 0.9 && < 0.10.0 + , http-types >= 0.9 && < 0.11 , vector , conduit , conduit-combinators @@ -62,6 +62,7 @@ , bytestring , connection , docker + , directory , aeson , containers , unordered-containers diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs --- a/src/Docker/Client/Api.hs +++ b/src/Docker/Client/Api.hs @@ -43,7 +43,7 @@ import Docker.Client.Utils requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ()) -requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint +requestUnit verb endpoint = fmap (const ()) <$> requestHelper verb endpoint requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString) requestHelper verb endpoint = requestHelper' verb endpoint Conduit.sinkLbs diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -5,12 +5,13 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BSC import qualified Data.Conduit.Binary as CB -import Data.Text as T +import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Network.HTTP.Client as HTTP import Network.HTTP.Conduit (requestBodySourceChunked) import Network.HTTP.Types (Query, encodePath, encodePathSegments) +import Prelude hiding (all) import Docker.Client.Types @@ -26,7 +27,7 @@ getEndpoint :: ApiVersion -> Endpoint -> T.Text getEndpoint v VersionEndpoint = encodeURL [v, "version"] -getEndpoint v (ListContainersEndpoint _) = encodeURL [v, "containers", "json"] -- Make use of lsOpts here +getEndpoint v (ListContainersEndpoint (ListOpts all)) = encodeURLWithQuery [v, "containers", "json"] [("all", Just (encodeQ $ show all))] getEndpoint v (ListImagesEndpoint _) = encodeURL [v, "images", "json"] -- Make use of lsOpts here getEndpoint v (CreateContainerEndpoint _ cn) = case cn of Just cn -> encodeURLWithQuery [v, "containers", "create"] [("name", Just (encodeQ $ T.unpack cn))] 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 @@ -23,7 +23,7 @@ , ContainerPortInfo(..) , Container(..) , ContainerState(..) - , Status(..) + , State(..) , Digest , Label(..) , Tag @@ -238,7 +238,7 @@ , processLabel :: Text , resolveConfPath :: FilePath , restartCount :: Int - , state :: ContainerState + , containerDetailsState :: ContainerState , mounts :: [Mount] } deriving (Eq, Show, Generic) @@ -246,11 +246,11 @@ -- | Data type used for parsing the mount information from a container -- list. data Mount = Mount { - mountName :: Text + mountName :: Maybe Text -- this is optional , mountSource :: FilePath , mountDestination :: FilePath - , mountDriver :: Text - , mountMode :: Maybe VolumePermission -- apparently this can be null + , mountDriver :: Maybe Text + -- , mountMode :: Maybe VolumePermission -- apparently this can be null , mountRW :: Bool , mountPropogation :: Text } @@ -258,14 +258,14 @@ instance FromJSON Mount where parseJSON (JSON.Object o) = do - name <- o .: "Name" + name <- o .:? "Name" src <- o .: "Source" dest <- o .: "Destination" - driver <- o .: "Driver" - mode <- o .: "Mode" + driver <- o .:? "Driver" + -- mode <- o .: "Mode" rw <- o .: "RW" prop <- o .: "Propagation" - return $ Mount name src dest driver mode rw prop + return $ Mount name src dest driver rw prop parseJSON _ = fail "Mount is not an object" -- | Data type used for parsing the container state from a list of @@ -281,7 +281,7 @@ , restarting :: Bool , running :: Bool , startedAt :: UTCTime - , status :: Status + , state :: State } deriving (Eq, Show, Generic) @@ -511,7 +511,8 @@ , containerImageId :: ImageID , containerCommand :: Text , containerCreatedAt :: Int - , containerStatus :: Status + , containerState :: State + , containerStatus :: Maybe Text , containerPorts :: [ContainerPortInfo] , containerLabels :: [Label] , containerNetworks :: [Network] @@ -519,13 +520,14 @@ } deriving (Show, Eq) instance FromJSON Container where - parseJSON (JSON.Object v) = - Container <$> (v .: "Id") + parseJSON o@(JSON.Object v) = + Container <$> parseJSON o <*> (v .: "Names") <*> (v .: "Image") - <*> (v .: "ImageID") - <*> (v .: "Command") + <*> (v .: "ImageID") -- Doesn't exist anymore + <*> (v .: "Command") -- Doesn't exist anymore <*> (v .: "Created") + <*> (v .: "State") <*> (v .: "Status") <*> (v .: "Ports") <*> (v .: "Labels") @@ -535,21 +537,20 @@ parseNetworks (JSON.Object v) = (v .: "Networks") >>= parseJSON parseNetworks _ = fail "Container NetworkSettings: Not a JSON object." - parseJSON _ = fail "Container: Not a JSON object." --- | Represents the status of the container life cycle. -data Status = Created | Restarting | Running | Paused | Exited | Dead +-- | Represents the state of the container life cycle. +data State = Created | Restarting | Running | Paused | Exited | Dead deriving (Eq, Show, Generic) -instance FromJSON Status where +instance FromJSON State where parseJSON (JSON.String "running") = return Running parseJSON (JSON.String "created") = return Created -- Note: Guessing on the string values of these. parseJSON (JSON.String "restarting") = return Restarting parseJSON (JSON.String "paused") = return Paused parseJSON (JSON.String "exited") = return Exited parseJSON (JSON.String "dead") = return Dead - parseJSON _ = fail "Unknown Status" + parseJSON s = fail $ "Unknown Status: " ++ show s -- | Alias for representing a RepoDigest. We could newtype this and add -- some validation. @@ -658,7 +659,7 @@ binds=[] , containerIDFile=Nothing , logConfig=LogDriverConfig JsonFile [] - , networkMode=Bridge + , networkMode=NetworkBridge , portBindings=[] , restartPolicy=RestartOff , volumeDriver=Nothing @@ -789,6 +790,8 @@ instance FromJSON VolumePermission where parseJSON "rw" = return ReadWrite parseJSON "ro" = return ReadOnly + parseJSON "RW" = return ReadWrite + parseJSON "RO" = return ReadOnly parseJSON _ = fail "Failed to parse VolumePermission" -- | Used for marking a directory in the container as "exposed" hence @@ -935,19 +938,21 @@ parseJSON _ = fail "LogDriverConfig is not an object" -- TODO: Add container: mode -data NetworkMode = Bridge | Host | NetworkDisabled +data NetworkMode = NetworkBridge | NetworkHost | NetworkDisabled | NetworkNamed Text deriving (Eq, Show, Ord) instance FromJSON NetworkMode where - parseJSON (JSON.String "bridge") = return Bridge - parseJSON (JSON.String "host") = return Host -- Note: Guessing on these. + parseJSON (JSON.String "bridge") = return NetworkBridge + parseJSON (JSON.String "host") = return NetworkHost -- Note: Guessing on these. parseJSON (JSON.String "none") = return NetworkDisabled + parseJSON (JSON.String n) = return $ NetworkNamed n parseJSON _ = fail "Unknown NetworkMode" instance ToJSON NetworkMode where - toJSON Bridge = JSON.String "bridge" - toJSON Host = JSON.String "host" - toJSON NetworkDisabled = JSON.String "none" + toJSON NetworkBridge = JSON.String "bridge" + toJSON NetworkHost = JSON.String "host" + toJSON NetworkDisabled = JSON.String "none" + toJSON (NetworkNamed n) = JSON.String n data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord) @@ -1348,7 +1353,7 @@ parseJSON _ = fail "EnvVar is not a string" instance ToJSON EnvVar where - toJSON (EnvVar n v) = object [n .= v] + toJSON (EnvVar n v) = JSON.String $ n <> T.pack "=" <> v -- | ExposedPort represents a port (and it's type) -- that a container should expose to other containers or the host system. diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -2,6 +2,7 @@ module Main where +import Prelude hiding (all) import qualified Test.QuickCheck.Monadic as QCM import Test.Tasty import Test.Tasty.HUnit @@ -9,6 +10,7 @@ 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 @@ -28,13 +30,14 @@ 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 -- opts = defaultClientOpts -testImageName = "docker-hs-test" +testImageName = "docker-hs/test" toStrict1 = B.concat . BL.toChunks @@ -54,30 +57,51 @@ 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 ((== [imageFullName]) . imageRepoTags) images + let xs = filter (elem imageFullName . imageRepoTags) images lift $ assert $ length xs == 1 where imageFullName = testImageName <> ":latest" +testListContainers :: IO () +testListContainers = + runDocker $ + do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing + c <- fromRight containerId + res <- listContainers $ ListOpts { all=True } + deleteContainer (DeleteOpts 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 = runDocker $ - do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing + do let containerConfig = (defaultContainerConfig (testImageName <> ":latest")) {env = [EnvVar "TEST" "123"]} + containerId <- createContainer (CreateOpts containerConfig defaultHostConfig) 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 + lift $ assertBool ("starting the container, unexpected status: " ++ show status1) $ isRightUnit status1 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 + lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3 where isRightUnit (Right ()) = True isRightUnit _ = False @@ -151,13 +175,25 @@ 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") + integrationTests :: TestTree integrationTests = testGroup "Integration Tests" [ testCase "Get docker version" testDockerVersion + , testCase "Build image from Dockerfile" testBuildFromDockerfile , testCase "Find image by name" testFindImage + , testCase "List containers" testListContainers , testCase "Run a dummy container and read its log" testRunAndReadLog + , testCase "Try to stop a container that doesn't exist" testStopNonexisting ] jsonTests :: TestTree @@ -169,11 +205,14 @@ , testLabelsJson , testLogDriverOptionsJson , testEntrypointJson + , testEnvVarJson ] setup :: IO () setup = system ("docker build -t " ++ unpack testImageName ++ " tests") >> return () +isLeft = not . isRight + isRight (Left _) = False isRight (Right _) = True @@ -193,4 +232,3 @@ Just _ -> do setup defaultMain $ testGroup "Tests" [jsonTests, integrationTests] -