diff --git a/Docker.hs b/Docker.hs new file mode 100644 --- /dev/null +++ b/Docker.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +module 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 Docker.Options +import 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) + diff --git a/Docker/Options.hs b/Docker/Options.hs new file mode 100644 --- /dev/null +++ b/Docker/Options.hs @@ -0,0 +1,16 @@ +module Docker.Options where + +import Data.Aeson.TH +import Docker.Utils + +dopts :: Options +dopts = Options { + fieldLabelModifier = strip_underscore + , constructorTagModifier = id + , allNullaryToStringTag = True + , omitNothingFields = True + , sumEncoding = defaultTaggedObject + } + + + diff --git a/Docker/Types.hs b/Docker/Types.hs new file mode 100644 --- /dev/null +++ b/Docker/Types.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module 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 Docker.Options +import GHC.Generics +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) + diff --git a/Docker/Utils.hs b/Docker/Utils.hs new file mode 100644 --- /dev/null +++ b/Docker/Utils.hs @@ -0,0 +1,6 @@ +module Docker.Utils where + +import Data.Char + +strip_underscore :: String -> String +strip_underscore (_:xs) = xs diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +playing around with haskell - don't use will be rebasing/force pushing alot diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/docker.cabal b/docker.cabal new file mode 100644 --- /dev/null +++ b/docker.cabal @@ -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: Docker, Docker.Options, Docker.Types, 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