b6f812a · docker-hs · git.iko.soy

.gitignore+2

@@ -1,3 +1,5 @@

11/.cabal-sandbox

22/cabal.sandbox.config

33/dist/

4+*~

5+.stack-work/

Network/Docker.hs+9

@@ -49,6 +49,8 @@ _dockerPostQuery endpoint clientOpts postObject = post (fullUrl clientOpts endpo

4949emptyPost = "" :: String

5050_dockerEmptyPostQuery endpoint clientOpts = post (fullUrl clientOpts endpoint) (toJSON emptyPost)

5151

52+_dockerEmptyDeleteQuery endpoint clientOpts = delete (fullUrl clientOpts endpoint)

53+

5254getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion)

5355getDockerVersion = decodeResponse . _dockerGetQuery "/version"

5456

@@ -79,6 +81,13 @@ pauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPos

7981unpauseContainer :: DockerClientOpts -> String -> IO (Status)

8082unpauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/unpause" containerId) clientOpts

8183

84+deleteContainer :: DockerClientOpts -> String -> IO (Status)

85+deleteContainer = deleteContainerWithOpts defaultDeleteOpts

86+

87+deleteContainerWithOpts :: DeleteOpts -> DockerClientOpts -> String -> IO (Status)

88+deleteContainerWithOpts (DeleteOpts removeVolumes force) clientOpts containerId = (^. responseStatus) <$> _dockerEmptyDeleteQuery req clientOpts

89+ where req = printf "/containers/%s?v=%s;force=%s" containerId (show removeVolumes) (show force)

90+

8291getContainerLogsStream :: DockerClientOpts -> String -> IO ()

8392getContainerLogsStream clientOpts containerId = do

8493 req <- PH.parseUrl (fullUrl clientOpts url)

Network/Docker/Types.hs+21

@@ -6,6 +6,7 @@

66

77module Network.Docker.Types where

88

9+import Prelude hiding(id)

910import Control.Applicative

1011import Control.Lens.TH

1112import Control.Lens.TH

@@ -68,6 +69,13 @@ data PortMap = PortMap

6869 , _type :: PortType

6970 } deriving (Show, Eq)

7071

72+data DeleteOpts = DeleteOpts

73+ { removeVolumes :: Bool

74+ , force :: Bool

75+ }

76+

77+defaultDeleteOpts = DeleteOpts False False

78+

7179

7280data DockerContainer = DockerContainer

7381 { _containerId :: ResourceId

@@ -161,6 +169,7 @@ data StartContainerOpts = StartContainerOpts

161169 , _Privileged :: Bool

162170 , _Dns :: [T.Text]

163171 , _VolumesFrom :: [T.Text]

172+ , _RestartPolicy :: RestartPolicy

164173 } deriving (Show)

165174

166175defaultStartOpts = StartContainerOpts

@@ -172,6 +181,7 @@ defaultStartOpts = StartContainerOpts

172181 , _Privileged = False

173182 , _Dns = []

174183 , _VolumesFrom = []

184+ , _RestartPolicy = RestartNever

175185 }

176186

177187instance ToJSON StartContainerOpts where

@@ -184,8 +194,19 @@ instance ToJSON StartContainerOpts where

184194 , "Privileged" .= _Privileged

185195 , "Dns" .= _Dns

186196 , "VolumesFrom" .= _VolumesFrom

197+ , "RestartPolicy" .= _RestartPolicy

187198 ]

188199

200+data RestartPolicy = RestartNever

201+ | RestartAlways

202+ | RestartOnFailure Int

203+ deriving (Show)

204+

205+instance ToJSON RestartPolicy where

206+ toJSON RestartNever = object ["Name" .= (""::String), "MaximumRetryCount" .= (0::Int) ]

207+ toJSON RestartAlways = object ["Name" .= ("always"::String), "MaximumRetryCount" .= (0::Int) ]

208+ toJSON (RestartOnFailure n) = object ["Name" .= ("on-failure"::String), "MaximumRetryCount" .= n ]

209+

189210makeClassy ''ResourceId

190211

191212-- makeLenses ''CreateContainerResponse

docker.cabal+40−13

@@ -2,7 +2,7 @@

22-- documentation, see http://haskell.org/cabal/users-guide/

33

44name: docker

5−version: 0.2.0.0

5+version: 0.2.0.1

66synopsis: Haskell wrapper for Docker Remote API

77-- description:

88homepage: https://github.com/denibertovic/docker-hs

@@ -21,18 +21,45 @@ library

2121 exposed-modules: Network.Docker, Network.Docker.Options, Network.Docker.Types, Network.Docker.Utils

2222 -- other-modules:

2323 other-extensions: OverloadedStrings, DeriveFunctor, FlexibleContexts, TemplateHaskell

24− build-depends: base >=4.7 && <4.8

25− , lens >=4.2 && <4.3

26− , aeson >=0.7 && <0.8

27− , bytestring >=0.10 && <0.11

28− , text >=1.1 && <1.2

29− , wreq >=0.1 && <0.2

30− , containers >=0.5 && <0.6

24+ build-depends: base >=4.7

25+ , lens >=4.2

26+ , aeson >=0.7

27+ , lens-aeson

28+ , bytestring >= 0.10

29+ , text >=1.1

30+ , wreq >=0.3

31+ , containers >= 0.5

32+ , data-default >= 0.5.3

33+ , network-uri >= 2.6.0.1

34+ , pipes-http >= 1.0.0

35+ , pipes >= 4.1.2

36+ , pipes-text >= 0.0.0.12

37+ , pipes-bytestring >= 2.1.0

38+ -- hs-source-dirs:

39+ default-language: Haskell2010

40+

41+test-suite tests

42+ build-depends: base >=4.7

43+ , docker

44+ , lens >=4.2

45+ , aeson >=0.7

46+ , lens-aeson

47+ , bytestring >= 0.10

48+ , text >=1.1

49+ , wreq >=0.3

50+ , containers >= 0.5

3151 , data-default >= 0.5.3

32− , network-uri >= 2.6.0.1

33− , pipes-http >= 1.0.0, pipes >= 4.1.2

52+ , pipes >= 4.1.2

53+ , pipes-http >= 1.0.0

3454 , pipes-text >= 0.0.0.12

3555 , pipes-bytestring >= 2.1.0

36− , free >= 4.9

37− -- hs-source-dirs:

38− default-language: Haskell2010

56+ , tasty >= 0.10.1

57+ , tasty-quickcheck >= 0.8.2

58+ , QuickCheck >= 2.7

59+ , tasty-hunit >= 0.8

60+ , process

61+ , http-types

62+ type: exitcode-stdio-1.0

63+ main-is: tests.hs

64+ hs-source-dirs: tests

65+ default-language: Haskell2010

stack.yamlnew file+12

@@ -0,0 +1,12 @@

1+flags: {}

2+packages:

3+- '.'

4+extra-deps:

5+- wreq-0.4.0.0

6+- pipes-http-1.0.2

7+- pipes-group-1.0.2

8+- pipes-safe-2.2.2

9+- pipes-text-0.0.0.16

10+- pipes-bytestring-2.1.1

11+- psqueues-0.2.0.2

12+resolver: lts-1.15

tests/Dockerfilenew file+7

@@ -0,0 +1,7 @@

1+FROM debian

2+

3+RUN apt-get update && apt-get install -y python

4+

5+RUN echo "#!/usr/bin/python\nprint '123'" > /entrypoint.py

6+RUN chmod +x /entrypoint.py

7+CMD ["python", "entrypoint.py"]

tests/tests.hsnew file+62

@@ -0,0 +1,62 @@

1+module Main where

2+

3+import Network.Docker

4+import Network.Docker.Types

5+

6+import Test.Tasty

7+import Test.Tasty.HUnit

8+import qualified Test.Tasty.QuickCheck as QC

9+import qualified Test.QuickCheck.Monadic as QCM

10+

11+import Data.Maybe (isJust, fromJust)

12+import System.Process (system)

13+import Data.Text (unpack)

14+import Control.Concurrent (threadDelay)

15+import Network.HTTP.Types.Status

16+import qualified Data.ByteString.Char8 as C

17+import qualified Data.ByteString as B

18+import qualified Data.ByteString.Lazy as BL

19+

20+opts = defaultClientOpts { baseUrl = "http://127.0.0.1:2375/" }

21+

22+test_image_name = "docker-hs-test"

23+

24+toStrict1 = B.concat . BL.toChunks

25+

26+checkDockerVersion :: IO ()

27+checkDockerVersion = do v <- getDockerVersion opts

28+ assert $ isJust v

29+

30+findTestImage :: IO ()

31+findTestImage = do images <- getDockerImages opts

32+ let x = fmap (filter ((== [test_image_name++":latest"]) . _repoTags)) images

33+ assert $ fmap length x == Just 1

34+

35+runAndReadLog :: IO ()

36+runAndReadLog = do containerId <- createContainer opts (defaultCreateOpts {_image = test_image_name++":latest"})

37+ assert $ isJust containerId

38+ let c = unpack $ fromJust containerId

39+ status1 <- startContainer opts c defaultStartOpts

40+ threadDelay 300000 -- give 300ms for the application to finish

41+ assert $ status1 == status204

42+ status2 <- killContainer opts c

43+ logs <- getContainerLogs opts c

44+ assert $ status2 == status204

45+ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)

46+ status3 <- deleteContainer opts c

47+ assert $ status3 == status204

48+

49+

50+tests :: TestTree

51+tests = testGroup "Metrics tests" [

52+ testCase "Get docker version" checkDockerVersion,

53+ testCase "Find image by name" findTestImage,

54+ testCase "Run a dummy container and read its log" runAndReadLog]

55+

56+setup :: IO()

57+setup = system ("docker build -t "++test_image_name++" tests") >> return ()

58+

59+main :: IO()

60+main = do

61+ setup

62+ defaultMain tests