mirror of
https://github.com/ilyakooo0/docker-hs.git
synced 2024-09-11 10:35:29 +03:00
Merge branch 'bug/listcontainers' into pr48
This commit is contained in:
commit
09fb91220b
2
Makefile
2
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:
|
||||
|
@ -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))]
|
||||
|
@ -249,8 +249,8 @@ data Mount = Mount {
|
||||
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 @@ 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
|
||||
@ -523,8 +523,8 @@ instance FromJSON Container where
|
||||
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 .: "Ports")
|
||||
@ -535,11 +535,10 @@ instance FromJSON Container where
|
||||
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
|
||||
data Status = ContainerStatus T.Text
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance FromJSON Status where
|
||||
@ -789,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
|
||||
|
@ -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
|
||||
@ -69,6 +71,18 @@ testFindImage =
|
||||
where
|
||||
imageFullName = testImageName <> ":latest"
|
||||
|
||||
testListContainers :: IO ()
|
||||
testListContainers =
|
||||
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
|
||||
cur <- getCurrentDirectory
|
||||
@ -170,6 +184,7 @@ integrationTests =
|
||||
[ 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
|
||||
]
|
||||
|
Loading…
Reference in New Issue
Block a user