mirror of
https://github.com/ilyakooo0/docker-hs.git
synced 2024-09-11 10:35:29 +03:00
initial commit
This commit is contained in:
commit
8b91ae3266
3
.gitignore
vendored
Normal file
3
.gitignore
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
/.cabal-sandbox
|
||||
/cabal.sandbox.config
|
||||
/dist/
|
30
LICENSE
Normal file
30
LICENSE
Normal file
@ -0,0 +1,30 @@
|
||||
Copyright (c) 2014, Deni Bertovic
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Deni Bertovic nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
92
Network/Docker.hs
Normal file
92
Network/Docker.hs
Normal file
@ -0,0 +1,92 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Network.Docker where
|
||||
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Lens
|
||||
import Data.Aeson (FromJSON, ToJSON, decode, eitherDecode,
|
||||
encode)
|
||||
import Data.Aeson.Lens (key, _String)
|
||||
import Data.Aeson.TH
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Char
|
||||
import qualified Data.Text as T
|
||||
import Network.Docker.Options
|
||||
import Network.Docker.Types
|
||||
import Network.Wreq
|
||||
import Pipes
|
||||
import qualified Pipes.ByteString as PB
|
||||
import qualified Pipes.HTTP as PH
|
||||
import Text.Printf (printf)
|
||||
|
||||
|
||||
defaultClientOpts :: DockerClientOpts
|
||||
defaultClientOpts = DockerClientOpts
|
||||
{ apiVersion = "v1.12"
|
||||
, baseUrl = "http://127.0.0.1:3128/"
|
||||
}
|
||||
|
||||
constructUrl :: URL -> ApiVersion -> Endpoint -> URL
|
||||
constructUrl url apiVersion endpoint = printf "%s%s%s" url apiVersion endpoint
|
||||
|
||||
constructRelativeUrl url = url :: String
|
||||
|
||||
decodeResponse r = decode <$> (^. responseBody) <$> r
|
||||
|
||||
getOutOfResponse k r = (^? responseBody . key k . _String) r
|
||||
|
||||
getResponseStatusCode r = (^. responseStatus) r
|
||||
|
||||
fullUrl :: DockerClientOpts -> Endpoint -> URL
|
||||
fullUrl clientOpts endpoint = constructUrl (baseUrl clientOpts) (apiVersion clientOpts) endpoint
|
||||
|
||||
_dockerGetQuery :: Endpoint -> DockerClientOpts -> IO(Response L.ByteString)
|
||||
_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)
|
||||
|
||||
emptyPost = "" :: String
|
||||
_dockerEmptyPostQuery endpoint clientOpts = post (fullUrl clientOpts endpoint) (encode emptyPost)
|
||||
|
||||
getDockerVersion :: DockerClientOpts -> IO (Maybe DockerVersion)
|
||||
getDockerVersion = decodeResponse . _dockerGetQuery "/version"
|
||||
|
||||
getDockerContainers :: DockerClientOpts -> IO (Maybe [DockerContainer])
|
||||
getDockerContainers = decodeResponse . _dockerGetQuery "/containers/json"
|
||||
|
||||
getDockerImages :: DockerClientOpts -> IO (Maybe [DockerImage])
|
||||
getDockerImages = decodeResponse . _dockerGetQuery "/images/json"
|
||||
|
||||
createContainer :: DockerClientOpts -> CreateContainerOpts -> IO(Maybe T.Text)
|
||||
createContainer clientOpts createOpts = getOutOfResponse "Id" <$> (_dockerPostQuery "/containers/create" clientOpts createOpts)
|
||||
|
||||
startContainer :: DockerClientOpts -> String -> StartContainerOpts -> IO(Status)
|
||||
startContainer clientOpts containerId startOpts = (^. responseStatus) <$> _dockerPostQuery (printf "/containers/%s/start" containerId) clientOpts startOpts
|
||||
|
||||
stopContainer :: DockerClientOpts -> String -> IO (Status)
|
||||
stopContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/stop" containerId) clientOpts
|
||||
|
||||
killContainer :: DockerClientOpts -> String -> IO (Status)
|
||||
killContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/kill" containerId) clientOpts
|
||||
|
||||
restartContainer :: DockerClientOpts -> String -> IO (Status)
|
||||
restartContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/restart" containerId) clientOpts
|
||||
|
||||
pauseContainer :: DockerClientOpts -> String -> IO (Status)
|
||||
pauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/pause" containerId) clientOpts
|
||||
|
||||
unpauseContainer :: DockerClientOpts -> String -> IO (Status)
|
||||
unpauseContainer clientOpts containerId = (^. responseStatus) <$> _dockerEmptyPostQuery (printf "/containers/%s/unpause" containerId) clientOpts
|
||||
|
||||
getContainerLogsStream :: DockerClientOpts -> String -> IO ()
|
||||
getContainerLogsStream clientOpts containerId = do
|
||||
req <- PH.parseUrl (fullUrl clientOpts url)
|
||||
let req' = req {PH.method = "GET"}
|
||||
PH.withManager PH.defaultManagerSettings $ \m -> PH.withHTTP req' m $ \resp -> runEffect $ PH.responseBody resp >-> PB.stdout
|
||||
where url = (printf "/containers/%s/logs?stdout=1&stderr=1&follow=1" containerId)
|
||||
|
||||
getContainerLogs :: DockerClientOpts -> String -> IO (L.ByteString)
|
||||
getContainerLogs clientOpts containerId = (^. responseBody) <$> _dockerGetQuery url clientOpts
|
||||
where url = (printf "/containers/%s/logs?stdout=1&stderr=1" containerId)
|
||||
|
16
Network/Docker/Options.hs
Normal file
16
Network/Docker/Options.hs
Normal file
@ -0,0 +1,16 @@
|
||||
module Network.Docker.Options where
|
||||
|
||||
import Data.Aeson.TH
|
||||
import Network.Docker.Utils
|
||||
|
||||
dopts :: Options
|
||||
dopts = Options {
|
||||
fieldLabelModifier = strip_underscore
|
||||
, constructorTagModifier = id
|
||||
, allNullaryToStringTag = True
|
||||
, omitNothingFields = True
|
||||
, sumEncoding = defaultTaggedObject
|
||||
}
|
||||
|
||||
|
||||
|
234
Network/Docker/Types.hs
Normal file
234
Network/Docker/Types.hs
Normal file
@ -0,0 +1,234 @@
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Network.Docker.Types where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Lens.TH
|
||||
import Control.Lens.TH
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.Bool
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Data.Default
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import Network.Docker.Options
|
||||
import Network.Wreq.Types (Postable)
|
||||
|
||||
|
||||
type URL = String
|
||||
type ApiVersion = String
|
||||
type Endpoint = String
|
||||
|
||||
type Tag = String
|
||||
type IP = String
|
||||
type Port = Int
|
||||
type PortType = String
|
||||
|
||||
data DockerClientOpts = DockerClientOpts {
|
||||
apiVersion :: ApiVersion
|
||||
, baseUrl :: URL
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
data ResourceId = ResourceId { _id :: String } deriving (Show, Eq)
|
||||
|
||||
|
||||
data DockerImage = DockerImage
|
||||
{ _imageId :: ResourceId
|
||||
, _imageCreatedAt :: Int
|
||||
, _parentId :: Maybe String
|
||||
, _repoTags :: [Tag]
|
||||
, _size :: Int
|
||||
, _virtualSize :: Int
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
data DockerVersion = DockerVersion
|
||||
{ _Version :: String
|
||||
, _GitCommit :: String
|
||||
, _GoVersion :: String
|
||||
, _Arch :: String
|
||||
, _KernelVersion :: String
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
-- The JSON looks likes this:
|
||||
-- "Ports":[{"IP":"0.0.0.0","PrivatePort":55555,"PublicPort":55555,"Type":"tcp"}]
|
||||
|
||||
data PortMap = PortMap
|
||||
{ _ip :: IP
|
||||
, _privatePort :: Port
|
||||
, _publicPort :: Port
|
||||
, _type :: PortType
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
data DockerContainer = DockerContainer
|
||||
{ _containerId :: ResourceId
|
||||
, _containerImageId :: ResourceId
|
||||
, _command :: String
|
||||
, _containerCreatedAt :: Int
|
||||
, _names :: [String]
|
||||
, _status :: String
|
||||
, _ports :: Maybe [PortMap]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
data CreateContainerOpts = CreateContainerOpts
|
||||
{ _hostname :: String
|
||||
, _user :: String
|
||||
, _memory :: Int
|
||||
, _memorySwap :: Int
|
||||
, _attachStdin :: Bool
|
||||
, _attachStdout :: Bool
|
||||
, _attachStderr :: Bool
|
||||
, _portSpecs :: Maybe Object
|
||||
, _tty :: Bool
|
||||
, _openStdin :: Bool
|
||||
, _stdinOnce :: Bool
|
||||
, _env :: Maybe Object
|
||||
, _cmd :: [String]
|
||||
, _image :: String
|
||||
, _volumes :: Maybe Object
|
||||
, _volumesFrom :: Maybe Object
|
||||
, _workingDir :: String
|
||||
, _disableNetwork :: Bool
|
||||
, _exposedPorts :: Maybe Object
|
||||
} deriving (Show)
|
||||
|
||||
defaultCreateOpts = CreateContainerOpts {
|
||||
_hostname = ""
|
||||
, _user = ""
|
||||
, _memory = 0
|
||||
, _memorySwap = 0
|
||||
, _attachStdin = False
|
||||
, _attachStdout = False
|
||||
, _attachStderr = False
|
||||
, _portSpecs = Nothing
|
||||
, _tty = False
|
||||
, _openStdin = False
|
||||
, _stdinOnce = False
|
||||
, _env = Nothing
|
||||
, _cmd = []
|
||||
, _image = "debian"
|
||||
, _volumes = Nothing
|
||||
, _volumesFrom = Nothing
|
||||
, _workingDir = ""
|
||||
, _disableNetwork = False
|
||||
, _exposedPorts = Nothing
|
||||
}
|
||||
|
||||
instance ToJSON CreateContainerOpts where
|
||||
toJSON (CreateContainerOpts {..}) = object
|
||||
[ "Hostname" .= _hostname
|
||||
, "User" .= _user
|
||||
, "Memory" .= _memory
|
||||
, "MemorySwap" .= _memorySwap
|
||||
, "AttachStdin" .= _attachStdin
|
||||
, "AttachStdout" .= _attachStdout
|
||||
, "AttachStderr" .= _attachStderr
|
||||
, "PortSpecs" .= _portSpecs
|
||||
, "Tty" .= _tty
|
||||
, "OpenStdin" .= _openStdin
|
||||
, "StdinOnce" .= _stdinOnce
|
||||
, "Env" .= _env
|
||||
, "Cmd" .= _cmd
|
||||
, "Image" .= _image
|
||||
, "Volumes" .= _volumes
|
||||
, "VolumesFrom" .= _volumesFrom
|
||||
, "WrokingDir" .= _workingDir
|
||||
, "DisableNetwork" .= _disableNetwork
|
||||
, "ExposedPorts" .= _exposedPorts
|
||||
]
|
||||
|
||||
-- data CreateContainerResponse = CreateContainerResponse
|
||||
-- { _createdContainerId :: String
|
||||
-- , _warnings :: Maybe [T.Text]
|
||||
-- } deriving (Show)
|
||||
|
||||
data StartContainerOpts = StartContainerOpts
|
||||
{ _Binds :: [T.Text]
|
||||
, _Links :: [T.Text]
|
||||
, _LxcConf :: [(T.Text, T.Text)]
|
||||
, _PortBindings :: [(T.Text, [(T.Text, T.Text)])]
|
||||
, _PublishAllPorts :: Bool
|
||||
, _Privileged :: Bool
|
||||
, _Dns :: [T.Text]
|
||||
, _VolumesFrom :: [T.Text]
|
||||
} deriving (Show)
|
||||
|
||||
defaultStartOpts = StartContainerOpts
|
||||
{ _Binds = []
|
||||
, _Links = []
|
||||
, _LxcConf = []
|
||||
, _PortBindings = []
|
||||
, _PublishAllPorts = False
|
||||
, _Privileged = False
|
||||
, _Dns = []
|
||||
, _VolumesFrom = []
|
||||
}
|
||||
|
||||
instance ToJSON StartContainerOpts where
|
||||
toJSON (StartContainerOpts {..}) = object
|
||||
[ "Binds" .= _Binds
|
||||
, "Links" .= _Links
|
||||
, "LxcConf" .= _LxcConf
|
||||
, "PortBindings" .= _PortBindings
|
||||
, "PublishAllPorts" .= _PublishAllPorts
|
||||
, "Privileged" .= _Privileged
|
||||
, "Dns" .= _Dns
|
||||
, "VolumesFrom" .= _VolumesFrom
|
||||
]
|
||||
|
||||
makeClassy ''ResourceId
|
||||
|
||||
-- makeLenses ''CreateContainerResponse
|
||||
makeLenses ''DockerImage
|
||||
makeLenses ''DockerContainer
|
||||
makeLenses ''CreateContainerOpts
|
||||
|
||||
instance HasResourceId DockerImage where
|
||||
resourceId = imageId
|
||||
|
||||
instance FromJSON DockerImage where
|
||||
parseJSON (Object v) =
|
||||
DockerImage <$> ResourceId <$> (v .: "Id")
|
||||
<*> (v .: "Created")
|
||||
<*> (v .:? "ParentId")
|
||||
<*> (v .: "RepoTags")
|
||||
<*> (v .: "Size")
|
||||
<*> (v .: "VirtualSize")
|
||||
|
||||
instance FromJSON PortMap where
|
||||
parseJSON (Object v) =
|
||||
PortMap <$> (v .: "IP")
|
||||
<*> (v .: "PrivatePort")
|
||||
<*> (v .: "PublicPort")
|
||||
<*> (v .: "Type")
|
||||
|
||||
instance HasResourceId DockerContainer where
|
||||
resourceId = containerId
|
||||
|
||||
instance FromJSON DockerContainer where
|
||||
parseJSON (Object v) =
|
||||
DockerContainer <$> (ResourceId <$> (v .: "Id"))
|
||||
<*> (ResourceId <$> (v .: "Id"))
|
||||
<*> (v .: "Command")
|
||||
<*> (v .: "Created")
|
||||
<*> (v .: "Names")
|
||||
<*> (v .: "Status")
|
||||
<*> (v .:? "Ports")
|
||||
|
||||
-- instance FromJSON CreateContainerResponse where
|
||||
-- parseJSON (Object v) =
|
||||
-- CreateContainerResponse <$> (v .: "Id")
|
||||
-- <*> (v .:? "warnings")
|
||||
|
||||
$(deriveJSON dopts ''DockerVersion)
|
||||
|
6
Network/Docker/Utils.hs
Normal file
6
Network/Docker/Utils.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Network.Docker.Utils where
|
||||
|
||||
import Data.Char
|
||||
|
||||
strip_underscore :: String -> String
|
||||
strip_underscore (_:xs) = xs
|
3
README.md
Normal file
3
README.md
Normal file
@ -0,0 +1,3 @@
|
||||
# Docker Remote API wrapper for Haskell
|
||||
|
||||
## Work in progress
|
26
docker.cabal
Normal file
26
docker.cabal
Normal file
@ -0,0 +1,26 @@
|
||||
-- Initial docker.cabal generated by cabal init. For further
|
||||
-- documentation, see http://haskell.org/cabal/users-guide/
|
||||
|
||||
name: docker
|
||||
version: 0.1.0.0
|
||||
synopsis: Haskell wrapper for Docker Remote API
|
||||
-- description:
|
||||
homepage: https://github.com/denibertovic/docker-hs
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Deni Bertovic
|
||||
maintainer: deni@denibertovic.com
|
||||
-- copyright:
|
||||
category: Network
|
||||
build-type: Simple
|
||||
extra-source-files: README.md
|
||||
cabal-version: >=1.10
|
||||
stability: experimental
|
||||
|
||||
library
|
||||
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
|
||||
-- hs-source-dirs:
|
||||
default-language: Haskell2010
|
Loading…
Reference in New Issue
Block a user