diff --git a/Network/Docker.hs b/Network/Docker.hs --- a/Network/Docker.hs +++ b/Network/Docker.hs @@ -5,7 +5,7 @@ import Control.Applicative ((<$>), (<*>)) import Control.Lens import Data.Aeson (FromJSON, ToJSON, decode, eitherDecode, - encode) + toJSON) import Data.Aeson.Lens (key, _String) import Data.Aeson.TH import qualified Data.ByteString.Lazy as L @@ -44,11 +44,13 @@ _dockerGetQuery endpoint clientOpts = get (fullUrl clientOpts endpoint) _dockerPostQuery :: ToJSON a => Endpoint -> DockerClientOpts -> a -> IO (Response L.ByteString) -_dockerPostQuery endpoint clientOpts postObject = post (fullUrl clientOpts endpoint) (encode postObject) +_dockerPostQuery endpoint clientOpts postObject = post (fullUrl clientOpts endpoint) (toJSON postObject) emptyPost = "" :: String -_dockerEmptyPostQuery endpoint clientOpts = post (fullUrl clientOpts endpoint) (encode emptyPost) +_dockerEmptyPostQuery endpoint clientOpts = post (fullUrl clientOpts endpoint) (toJSON emptyPost) +_dockerEmptyDeleteQuery endpoint clientOpts = delete (fullUrl clientOpts endpoint) + getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion) getDockerVersion = decodeResponse . _dockerGetQuery "/version" @@ -78,6 +80,13 @@ unpauseContainer :: DockerClientOpts -> String -> IO (Status) unpauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/unpause" containerId) clientOpts + +deleteContainer :: DockerClientOpts -> String -> IO (Status) +deleteContainer = deleteContainerWithOpts defaultDeleteOpts + +deleteContainerWithOpts :: DeleteOpts -> DockerClientOpts -> String -> IO (Status) +deleteContainerWithOpts (DeleteOpts removeVolumes force) clientOpts containerId = (^. responseStatus) <$> _dockerEmptyDeleteQuery req clientOpts + where req = printf "/containers/%s?v=%s;force=%s" containerId (show removeVolumes) (show force) getContainerLogsStream :: DockerClientOpts -> String -> IO () getContainerLogsStream clientOpts containerId = do diff --git a/Network/Docker/Options.hs b/Network/Docker/Options.hs --- a/Network/Docker/Options.hs +++ b/Network/Docker/Options.hs @@ -4,12 +4,8 @@ import Network.Docker.Utils dopts :: Options -dopts = Options { +dopts = defaultOptions { fieldLabelModifier = strip_underscore - , constructorTagModifier = id - , allNullaryToStringTag = True - , omitNothingFields = True - , sumEncoding = defaultTaggedObject } diff --git a/Network/Docker/Types.hs b/Network/Docker/Types.hs --- a/Network/Docker/Types.hs +++ b/Network/Docker/Types.hs @@ -6,6 +6,7 @@ module Network.Docker.Types where +import Prelude hiding(id) import Control.Applicative import Control.Lens.TH import Control.Lens.TH @@ -68,7 +69,14 @@ , _type :: PortType } deriving (Show, Eq) +data DeleteOpts = DeleteOpts + { removeVolumes :: Bool + , force :: Bool + } +defaultDeleteOpts = DeleteOpts False False + + data DockerContainer = DockerContainer { _containerId :: ResourceId , _containerImageId :: ResourceId @@ -156,11 +164,12 @@ { _Binds :: [T.Text] , _Links :: [T.Text] , _LxcConf :: [(T.Text, T.Text)] - , _PortBindings :: [(T.Text, [(T.Text, T.Text)])] + , _PortBindings :: [((Int,T.Text),Int)] , _PublishAllPorts :: Bool , _Privileged :: Bool , _Dns :: [T.Text] , _VolumesFrom :: [T.Text] + , _RestartPolicy :: RestartPolicy } deriving (Show) defaultStartOpts = StartContainerOpts @@ -172,6 +181,7 @@ , _Privileged = False , _Dns = [] , _VolumesFrom = [] + , _RestartPolicy = RestartNever } instance ToJSON StartContainerOpts where @@ -179,12 +189,23 @@ [ "Binds" .= _Binds , "Links" .= _Links , "LxcConf" .= _LxcConf - , "PortBindings" .= _PortBindings + , "PortBindings" .= object (map (\((h,p),c)->T.concat [T.pack (show h),"/",p] .= [object ["HostPort" .= show c]]) _PortBindings) , "PublishAllPorts" .= _PublishAllPorts , "Privileged" .= _Privileged , "Dns" .= _Dns , "VolumesFrom" .= _VolumesFrom + , "RestartPolicy" .= _RestartPolicy ] + +data RestartPolicy = RestartNever + | RestartAlways + | RestartOnFailure Int + deriving (Show) + +instance ToJSON RestartPolicy where + toJSON RestartNever = object ["Name" .= (""::String), "MaximumRetryCount" .= (0::Int) ] + toJSON RestartAlways = object ["Name" .= ("always"::String), "MaximumRetryCount" .= (0::Int) ] + toJSON (RestartOnFailure n) = object ["Name" .= ("on-failure"::String), "MaximumRetryCount" .= n ] makeClassy ''ResourceId diff --git a/docker.cabal b/docker.cabal --- a/docker.cabal +++ b/docker.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: docker -version: 0.1.0.1 +version: 0.2.0.1 synopsis: Haskell wrapper for Docker Remote API -- description: homepage: https://github.com/denibertovic/docker-hs @@ -21,6 +21,45 @@ exposed-modules: Network.Docker, Network.Docker.Options, Network.Docker.Types, Network.Docker.Utils -- other-modules: other-extensions: OverloadedStrings, DeriveFunctor, FlexibleContexts, TemplateHaskell - build-depends: base >=4.7 && <4.8, lens >=4.2 && <4.3, aeson >=0.7 && <0.8, bytestring >=0.10 && <0.11, text >=1.1 && <1.2, wreq >=0.1 && <0.2, containers >=0.5 && <0.6, data-default >= 0.5.3, network-uri >= 2.6.0.1, pipes-http >= 1.0.0, pipes >= 4.1.2, pipes-text >= 0.0.0.12, pipes-bytestring >= 2.1.0 + build-depends: base >= 4.7 && < 4.8 + , lens >= 4.2 + , aeson >= 0.7 + , lens-aeson + , bytestring >= 0.10 + , text >= 1.1 + , wreq >= 0.3 + , containers >= 0.5 + , data-default >= 0.5.3 + , network-uri >= 2.6.0.1 + , pipes-http >= 1.0.0 + , pipes >= 4.1.2 + , pipes-text >= 0.0.0.12 + , pipes-bytestring >= 2.1.0 -- hs-source-dirs: default-language: Haskell2010 + +test-suite tests + build-depends: base >= 4.7 && < 4.8 + , docker + , lens >= 4.2 + , aeson >= 0.7 + , lens-aeson + , bytestring >= 0.10 + , text >= 1.1 + , wreq >= 0.3 + , containers >= 0.5 + , data-default >= 0.5.3 + , pipes >= 4.1.2 + , pipes-http >= 1.0.0 + , pipes-text >= 0.0.0.12 + , pipes-bytestring >= 2.1.0 + , tasty >= 0.10.1 + , tasty-quickcheck >= 0.8.2 + , QuickCheck >= 2.7 + , tasty-hunit >= 0.8 + , process + , http-types + type: exitcode-stdio-1.0 + main-is: tests.hs + hs-source-dirs: tests + default-language: Haskell2010 diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -0,0 +1,62 @@ +module Main where + +import Network.Docker +import Network.Docker.Types + +import Test.Tasty +import Test.Tasty.HUnit +import qualified Test.Tasty.QuickCheck as QC +import qualified Test.QuickCheck.Monadic as QCM + +import Data.Maybe (isJust, fromJust) +import System.Process (system) +import Data.Text (unpack) +import Control.Concurrent (threadDelay) +import Network.HTTP.Types.Status +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +opts = defaultClientOpts { baseUrl = "http://127.0.0.1:2375/" } + +test_image_name = "docker-hs-test" + +toStrict1 = B.concat . BL.toChunks + +checkDockerVersion :: IO () +checkDockerVersion = do v <- getDockerVersion opts + assert $ isJust v + +findTestImage :: IO () +findTestImage = do images <- getDockerImages opts + let x = fmap (filter ((== [test_image_name++":latest"]) . _repoTags)) images + assert $ fmap length x == Just 1 + +runAndReadLog :: IO () +runAndReadLog = do containerId <- createContainer opts (defaultCreateOpts {_image = test_image_name++":latest"}) + assert $ isJust containerId + let c = unpack $ fromJust containerId + status1 <- startContainer opts c defaultStartOpts + threadDelay 300000 -- give 300ms for the application to finish + assert $ status1 == status204 + status2 <- killContainer opts c + logs <- getContainerLogs opts c + assert $ status2 == status204 + assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs) + status3 <- deleteContainer opts c + assert $ status3 == status204 + + +tests :: TestTree +tests = testGroup "Metrics tests" [ + testCase "Get docker version" checkDockerVersion, + testCase "Find image by name" findTestImage, + testCase "Run a dummy container and read its log" runAndReadLog] + +setup :: IO() +setup = system ("docker build -t "++test_image_name++" tests") >> return () + +main :: IO() +main = do + setup + defaultMain tests