git.iko.soy/docker-hs
on master help sign in
initial commit
8b91ae3Deni Bertovic
.gitignorenew file+3
compare with master
unifiedsplit
@@ -0,0 +1,3 @@
1+/.cabal-sandbox
2+/cabal.sandbox.config
3+/dist/
LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2014, Deni Bertovic
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Deni Bertovic nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Network/Docker.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Network.Docker where
4+
5+import Control.Applicative ((<$>), (<*>))
6+import Control.Lens
7+import Data.Aeson (FromJSON, ToJSON, decode, eitherDecode,
8+ encode)
9+import Data.Aeson.Lens (key, _String)
10+import Data.Aeson.TH
11+import qualified Data.ByteString.Lazy as L
12+import Data.Char
13+import qualified Data.Text as T
14+import Network.Docker.Options
15+import Network.Docker.Types
16+import Network.Wreq
17+import Pipes
18+import qualified Pipes.ByteString as PB
19+import qualified Pipes.HTTP as PH
20+import Text.Printf (printf)
21+
22+
23+defaultClientOpts :: DockerClientOpts
24+defaultClientOpts = DockerClientOpts
25+ { apiVersion = "v1.12"
26+ , baseUrl = "http://127.0.0.1:3128/"
27+ }
28+
29+constructUrl :: URL -> ApiVersion -> Endpoint -> URL
30+constructUrl url apiVersion endpoint = printf "%s%s%s" url apiVersion endpoint
31+
32+constructRelativeUrl url = url :: String
33+
34+decodeResponse r = decode <$> (^. responseBody) <$> r
35+
36+getOutOfResponse k r = (^? responseBody . key k . _String) r
37+
38+getResponseStatusCode r = (^. responseStatus) r
39+
40+fullUrl :: DockerClientOpts -> Endpoint -> URL
41+fullUrl clientOpts endpoint = constructUrl (baseUrl clientOpts) (apiVersion clientOpts) endpoint
42+
43+_dockerGetQuery :: Endpoint -> DockerClientOpts -> IO(Response L.ByteString)
44+_dockerGetQuery endpoint clientOpts = get (fullUrl clientOpts endpoint)
45+
46+_dockerPostQuery :: ToJSON a => Endpoint -> DockerClientOpts -> a -> IO (Response L.ByteString)
47+_dockerPostQuery endpoint clientOpts postObject = post (fullUrl clientOpts endpoint) (encode postObject)
48+
49+emptyPost = "" :: String
50+_dockerEmptyPostQuery endpoint clientOpts = post (fullUrl clientOpts endpoint) (encode emptyPost)
51+
52+getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion)
53+getDockerVersion = decodeResponse . _dockerGetQuery "/version"
54+
55+getDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])
56+getDockerContainers = decodeResponse . _dockerGetQuery "/containers/json"
57+
58+getDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage])
59+getDockerImages = decodeResponse . _dockerGetQuery "/images/json"
60+
61+createContainer :: DockerClientOpts -> CreateContainerOpts -> IO(Maybe T.Text)
62+createContainer clientOpts createOpts = getOutOfResponse "Id" <$> (_dockerPostQuery "/containers/create" clientOpts createOpts)
63+
64+startContainer :: DockerClientOpts -> String -> StartContainerOpts -> IO(Status)
65+startContainer clientOpts containerId startOpts = (^. responseStatus) <$> _dockerPostQuery (printf "/containers/%s/start" containerId) clientOpts startOpts
66+
67+stopContainer :: DockerClientOpts -> String -> IO (Status)
68+stopContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/stop" containerId) clientOpts
69+
70+killContainer :: DockerClientOpts -> String -> IO (Status)
71+killContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/kill" containerId) clientOpts
72+
73+restartContainer :: DockerClientOpts -> String -> IO (Status)
74+restartContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/restart" containerId) clientOpts
75+
76+pauseContainer :: DockerClientOpts -> String -> IO (Status)
77+pauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/pause" containerId) clientOpts
78+
79+unpauseContainer :: DockerClientOpts -> String -> IO (Status)
80+unpauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/unpause" containerId) clientOpts
81+
82+getContainerLogsStream :: DockerClientOpts -> String -> IO ()
83+getContainerLogsStream clientOpts containerId = do
84+ req <- PH.parseUrl (fullUrl clientOpts url)
85+ let req' = req {PH.method = "GET"}
86+ PH.withManager PH.defaultManagerSettings $ \m -> PH.withHTTP req' m $ \resp -> runEffect $ PH.responseBody resp >-> PB.stdout
87+ where url = (printf "/containers/%s/logs?stdout=1&stderr=1&follow=1" containerId)
88+
89+getContainerLogs :: DockerClientOpts -> String -> IO (L.ByteString)
90+getContainerLogs clientOpts containerId = (^. responseBody) <$> _dockerGetQuery url clientOpts
91+ where url = (printf "/containers/%s/logs?stdout=1&stderr=1" containerId)
92+
Network/Docker/Options.hsnew file+16
@@ -0,0 +1,16 @@
1+module Network.Docker.Options where
2+
3+import Data.Aeson.TH
4+import Network.Docker.Utils
5+
6+dopts :: Options
7+dopts = Options {
8+ fieldLabelModifier = strip_underscore
9+ , constructorTagModifier = id
10+ , allNullaryToStringTag = True
11+ , omitNothingFields = True
12+ , sumEncoding = defaultTaggedObject
13+ }
14+
15+
16+
Network/Docker/Types.hsnew file+234
@@ -0,0 +1,234 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE TemplateHaskell #-}
6+
7+module Network.Docker.Types where
8+
9+import Control.Applicative
10+import Control.Lens.TH
11+import Control.Lens.TH
12+import Data.Aeson
13+import Data.Aeson.TH
14+import Data.Bool
15+import qualified Data.ByteString.Lazy as BS
16+import Data.Default
17+import qualified Data.Map as Map
18+import qualified Data.Text as T
19+import GHC.Generics
20+import Network.Docker.Options
21+import Network.Wreq.Types (Postable)
22+
23+
24+type URL = String
25+type ApiVersion = String
26+type Endpoint = String
27+
28+type Tag = String
29+type IP = String
30+type Port = Int
31+type PortType = String
32+
33+data DockerClientOpts = DockerClientOpts {
34+ apiVersion :: ApiVersion
35+ , baseUrl :: URL
36+ } deriving (Show)
37+
38+
39+data ResourceId = ResourceId { _id :: String } deriving (Show, Eq)
40+
41+
42+data DockerImage = DockerImage
43+ { _imageId :: ResourceId
44+ , _imageCreatedAt :: Int
45+ , _parentId :: Maybe String
46+ , _repoTags :: [Tag]
47+ , _size :: Int
48+ , _virtualSize :: Int
49+ } deriving (Show, Eq)
50+
51+
52+data DockerVersion = DockerVersion
53+ { _Version :: String
54+ , _GitCommit :: String
55+ , _GoVersion :: String
56+ , _Arch :: String
57+ , _KernelVersion :: String
58+ } deriving (Show, Eq)
59+
60+
61+-- The JSON looks likes this:
62+-- "Ports":[{"IP":"0.0.0.0","PrivatePort":55555,"PublicPort":55555,"Type":"tcp"}]
63+
64+data PortMap = PortMap
65+ { _ip :: IP
66+ , _privatePort :: Port
67+ , _publicPort :: Port
68+ , _type :: PortType
69+ } deriving (Show, Eq)
70+
71+
72+data DockerContainer = DockerContainer
73+ { _containerId :: ResourceId
74+ , _containerImageId :: ResourceId
75+ , _command :: String
76+ , _containerCreatedAt :: Int
77+ , _names :: [String]
78+ , _status :: String
79+ , _ports :: Maybe [PortMap]
80+ } deriving (Show, Eq)
81+
82+
83+data CreateContainerOpts = CreateContainerOpts
84+ { _hostname :: String
85+ , _user :: String
86+ , _memory :: Int
87+ , _memorySwap :: Int
88+ , _attachStdin :: Bool
89+ , _attachStdout :: Bool
90+ , _attachStderr :: Bool
91+ , _portSpecs :: Maybe Object
92+ , _tty :: Bool
93+ , _openStdin :: Bool
94+ , _stdinOnce :: Bool
95+ , _env :: Maybe Object
96+ , _cmd :: [String]
97+ , _image :: String
98+ , _volumes :: Maybe Object
99+ , _volumesFrom :: Maybe Object
100+ , _workingDir :: String
101+ , _disableNetwork :: Bool
102+ , _exposedPorts :: Maybe Object
103+ } deriving (Show)
104+
105+defaultCreateOpts = CreateContainerOpts {
106+ _hostname = ""
107+ , _user = ""
108+ , _memory = 0
109+ , _memorySwap = 0
110+ , _attachStdin = False
111+ , _attachStdout = False
112+ , _attachStderr = False
113+ , _portSpecs = Nothing
114+ , _tty = False
115+ , _openStdin = False
116+ , _stdinOnce = False
117+ , _env = Nothing
118+ , _cmd = []
119+ , _image = "debian"
120+ , _volumes = Nothing
121+ , _volumesFrom = Nothing
122+ , _workingDir = ""
123+ , _disableNetwork = False
124+ , _exposedPorts = Nothing
125+ }
126+
127+instance ToJSON CreateContainerOpts where
128+ toJSON (CreateContainerOpts {..}) = object
129+ [ "Hostname" .= _hostname
130+ , "User" .= _user
131+ , "Memory" .= _memory
132+ , "MemorySwap" .= _memorySwap
133+ , "AttachStdin" .= _attachStdin
134+ , "AttachStdout" .= _attachStdout
135+ , "AttachStderr" .= _attachStderr
136+ , "PortSpecs" .= _portSpecs
137+ , "Tty" .= _tty
138+ , "OpenStdin" .= _openStdin
139+ , "StdinOnce" .= _stdinOnce
140+ , "Env" .= _env
141+ , "Cmd" .= _cmd
142+ , "Image" .= _image
143+ , "Volumes" .= _volumes
144+ , "VolumesFrom" .= _volumesFrom
145+ , "WrokingDir" .= _workingDir
146+ , "DisableNetwork" .= _disableNetwork
147+ , "ExposedPorts" .= _exposedPorts
148+ ]
149+
150+-- data CreateContainerResponse = CreateContainerResponse
151+-- { _createdContainerId :: String
152+-- , _warnings :: Maybe [T.Text]
153+-- } deriving (Show)
154+
155+data StartContainerOpts = StartContainerOpts
156+ { _Binds :: [T.Text]
157+ , _Links :: [T.Text]
158+ , _LxcConf :: [(T.Text, T.Text)]
159+ , _PortBindings :: [(T.Text, [(T.Text, T.Text)])]
160+ , _PublishAllPorts :: Bool
161+ , _Privileged :: Bool
162+ , _Dns :: [T.Text]
163+ , _VolumesFrom :: [T.Text]
164+ } deriving (Show)
165+
166+defaultStartOpts = StartContainerOpts
167+ { _Binds = []
168+ , _Links = []
169+ , _LxcConf = []
170+ , _PortBindings = []
171+ , _PublishAllPorts = False
172+ , _Privileged = False
173+ , _Dns = []
174+ , _VolumesFrom = []
175+ }
176+
177+instance ToJSON StartContainerOpts where
178+ toJSON (StartContainerOpts {..}) = object
179+ [ "Binds" .= _Binds
180+ , "Links" .= _Links
181+ , "LxcConf" .= _LxcConf
182+ , "PortBindings" .= _PortBindings
183+ , "PublishAllPorts" .= _PublishAllPorts
184+ , "Privileged" .= _Privileged
185+ , "Dns" .= _Dns
186+ , "VolumesFrom" .= _VolumesFrom
187+ ]
188+
189+makeClassy ''ResourceId
190+
191+-- makeLenses ''CreateContainerResponse
192+makeLenses ''DockerImage
193+makeLenses ''DockerContainer
194+makeLenses ''CreateContainerOpts
195+
196+instance HasResourceId DockerImage where
197+ resourceId = imageId
198+
199+instance FromJSON DockerImage where
200+ parseJSON (Object v) =
201+ DockerImage <$> ResourceId <$> (v .: "Id")
202+ <*> (v .: "Created")
203+ <*> (v .:? "ParentId")
204+ <*> (v .: "RepoTags")
205+ <*> (v .: "Size")
206+ <*> (v .: "VirtualSize")
207+
208+instance FromJSON PortMap where
209+ parseJSON (Object v) =
210+ PortMap <$> (v .: "IP")
211+ <*> (v .: "PrivatePort")
212+ <*> (v .: "PublicPort")
213+ <*> (v .: "Type")
214+
215+instance HasResourceId DockerContainer where
216+ resourceId = containerId
217+
218+instance FromJSON DockerContainer where
219+ parseJSON (Object v) =
220+ DockerContainer <$> (ResourceId <$> (v .: "Id"))
221+ <*> (ResourceId <$> (v .: "Id"))
222+ <*> (v .: "Command")
223+ <*> (v .: "Created")
224+ <*> (v .: "Names")
225+ <*> (v .: "Status")
226+ <*> (v .:? "Ports")
227+
228+-- instance FromJSON CreateContainerResponse where
229+-- parseJSON (Object v) =
230+-- CreateContainerResponse <$> (v .: "Id")
231+-- <*> (v .:? "warnings")
232+
233+$(deriveJSON dopts ''DockerVersion)
234+
Network/Docker/Utils.hsnew file+6
@@ -0,0 +1,6 @@
1+module Network.Docker.Utils where
2+
3+import Data.Char
4+
5+strip_underscore :: String -> String
6+strip_underscore (_:xs) = xs
README.mdnew file+3
@@ -0,0 +1,3 @@
1+# Docker Remote API wrapper for Haskell
2+
3+## Work in progress
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
docker.cabalnew file+26
@@ -0,0 +1,26 @@
1+-- Initial docker.cabal generated by cabal init. For further
2+-- documentation, see http://haskell.org/cabal/users-guide/
3+
4+name: docker
5+version: 0.1.0.0
6+synopsis: Haskell wrapper for Docker Remote API
7+-- description:
8+homepage: https://github.com/denibertovic/docker-hs
9+license: BSD3
10+license-file: LICENSE
11+author: Deni Bertovic
12+maintainer: deni@denibertovic.com
13+-- copyright:
14+category: Network
15+build-type: Simple
16+extra-source-files: README.md
17+cabal-version: >=1.10
18+stability: experimental
19+
20+library
21+ exposed-modules: Network.Docker, Network.Docker.Options, Network.Docker.Types, Network.Docker.Utils
22+ -- other-modules:
23+ other-extensions: OverloadedStrings, DeriveFunctor, FlexibleContexts, TemplateHaskell
24+ 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
25+ -- hs-source-dirs:
26+ default-language: Haskell2010