ilyakooo0/docker-hs
1
0
Fork 0
mirror of https://github.com/ilyakooo0/docker-hs.git synced 2024-08-16 05:50:25 +03:00
Code Issues Projects Releases Wiki Activity

initial commit

Browse Source
This commit is contained in:
Deni Bertovic 2014-05-11 00:27:35 +02:00
commit 8b91ae3266
9 changed files with 412 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
/.cabal-sandbox
/cabal.sandbox.config
/dist/

30
LICENSE Normal file
View 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
View 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
View 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
View 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
View 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
View File

@ -0,0 +1,3 @@
# Docker Remote API wrapper for Haskell
## Work in progress

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

26
docker.cabal Normal file
View 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