docker 0.4.1.1 → 0.5.0.0
raw patch · 6 files changed
+111/−47 lines, 6 filesdep ~directorydep ~http-types
Dependency ranges changed: directory, http-types
Files
- README.md +25/−6
- docker.cabal +3/−2
- src/Docker/Client/Api.hs +1/−1
- src/Docker/Client/Internal.hs +3/−2
- src/Docker/Client/Types.hs +33/−28
- tests/tests.hs +46/−8
README.md view
@@ -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.-
docker.cabal view
@@ -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
src/Docker/Client/Api.hs view
@@ -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
src/Docker/Client/Internal.hs view
@@ -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))]
src/Docker/Client/Types.hs view
@@ -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:<name|id> 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.
tests/tests.hs view
@@ -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]-