From d7e30423b4bb48428774d7cede213709ed736b2a Mon Sep 17 00:00:00 2001 From: Deni Bertovic Date: Thu, 14 Dec 2017 16:34:03 +0100 Subject: [PATCH] WIP fixed listing containers --- Makefile | 2 +- src/Docker/Client/Internal.hs | 5 +++-- src/Docker/Client/Types.hs | 38 ++++++++++++++++++----------------- tests/tests.hs | 15 ++++++++++---- 4 files changed, 35 insertions(+), 25 deletions(-) diff --git a/Makefile b/Makefile index f3b6632..7a49b0e 100644 --- a/Makefile +++ b/Makefile @@ -18,7 +18,7 @@ repl: ## Run tests. Example RUN_INTEGRATION_TESTS=1 make test test: - @stack test + @RUN_INTEGRATION_TESTS=1 stack test ## Cut new release release: diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs index ca59d80..edf89b5 100644 --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -5,12 +5,13 @@ import qualified Data.Aeson as JSON 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 @@ encodeQ = encodeUtf8 . T.pack 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 index 7131494..cabf76b 100644 --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -246,11 +246,11 @@ data ContainerDetails = ContainerDetails { -- | Data type used for parsing the mount information from a container -- list. data Mount = Mount { - mountName :: Text + mountName :: Maybe Text , 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 @@ data Mount = Mount { 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 @@ -520,11 +520,11 @@ data Container = Container instance FromJSON Container where parseJSON o@(JSON.Object v) = - Container <$> (parseJSON o) + 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 .: "Status") <*> (v .: "Ports") @@ -538,17 +538,17 @@ instance FromJSON Container where parseJSON _ = fail "Container: Not a JSON object." -- | Represents the status of the container life cycle. -data Status = Created | Restarting | Running | Paused | Exited | Dead +data Status = ContainerStatus T.Text deriving (Eq, Show, Generic) instance FromJSON Status 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 (JSON.String s) = return $ ContainerStatus s + -- parseJSON (JSON.String "Created") = return Created + -- parseJSON (JSON.String "Restarting") = return Restarting + -- parseJSON (JSON.String "Paused") = return Paused + -- parseJSON (JSON.String "Exited") = parseExited s + -- parseJSON (JSON.String "Dead") = return Dead + parseJSON _ = fail "Failed to parse Status. Unknown Status." -- | Alias for representing a RepoDigest. We could newtype this and add -- some validation. @@ -788,6 +788,8 @@ instance ToJSON VolumePermission where 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 diff --git a/tests/tests.hs b/tests/tests.hs index a5a96e5..00d9f90 100644 --- 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 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 @@ -71,10 +73,15 @@ testFindImage = testListContainers :: IO () testListContainers = - runDocker $ - do res <- listContainers defaultListOpts - liftIO $ print res - lift $ assert $ isRight res + runDocker $ do + res <- listContainers $ ListOpts { all=True } + case res of + Right cs -> do + forM_ cs $ \r -> do + lift $ print (containerNetworks r) + lift $ print (containerStatus r) + Left e -> lift $ print e + lift $ assert $ isRight res testBuildFromDockerfile :: IO () testBuildFromDockerfile = do