mirror of
https://github.com/ilyakooo0/docker-hs.git
synced 2024-10-26 10:58:14 +03:00
WIP fixed listing containers
This commit is contained in:
parent
e78f6251c0
commit
d7e30423b4
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))]
|
||||
|
@ -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
|
||||
|
@ -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,9 +73,14 @@ testFindImage =
|
||||
|
||||
testListContainers :: IO ()
|
||||
testListContainers =
|
||||
runDocker $
|
||||
do res <- listContainers defaultListOpts
|
||||
liftIO $ print 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 ()
|
||||
|
Loading…
Reference in New Issue
Block a user