ilyakooo0/docker-hs
1
0
Fork 0
mirror of https://github.com/ilyakooo0/docker-hs.git synced 2024-09-11 10:35:29 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'pr48'

Browse Source
This commit is contained in:
Deni Bertovic 2018-01-09 00:51:00 +01:00
commit 051e5f5a9e
4 changed files with 39 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -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
src/Docker/Client/Internal.hs
View File

@ -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))]

43
src/Docker/Client/Types.hs
View File

@ -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 -- 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
@ -520,13 +520,13 @@ 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 .: "State")
<*> (v .: "Ports")
<*> (v .: "Labels")
<*> (v .: "NetworkSettings" >>= parseNetworks)
@ -535,7 +535,6 @@ 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.
@ -549,7 +548,7 @@ instance FromJSON Status where
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 +657,7 @@ defaultHostConfig = HostConfig {
binds=[]
, containerIDFile=Nothing
, logConfig=LogDriverConfig JsonFile []
, networkMode=Bridge
, networkMode=NetworkBridge
, portBindings=[]
, restartPolicy=RestartOff
, volumeDriver=Nothing
@ -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
@ -935,19 +936,21 @@ instance FromJSON LogDriverConfig where
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)

12
tests/tests.hs
View File

@ -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,15 @@ testFindImage =
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
@ -180,6 +191,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
]