git.iko.soy/docker-hs
on master help sign in
add unixHttpManager
7515583Philipp Balzarek
docker.cabal+1−1
compare with master
unifiedsplit
@@ -30,6 +30,7 @@ library
30 , http-types
30 , http-types
31 , blaze-builder
31 , blaze-builder
32 , containers
32 , containers
33+ , network >= 2.6
33 , network-uri
34 , network-uri
34 , mtl
35 , mtl
35 , transformers
36 , transformers
@@ -51,4 +52,3 @@ test-suite docker-hs-tests
51source-repository head
52source-repository head
52 type: git
53 type: git
53 location: https://github.com/denibertovic/docker-hs
54 location: https://github.com/denibertovic/docker-hs
54−
src/Docker/Internal.hs+26−3
@@ -9,10 +9,13 @@ import Data.Text as T
9import Data.Text (Text)
9import Data.Text (Text)
10import Data.Text.Encoding (decodeUtf8, encodeUtf8)
10import Data.Text.Encoding (decodeUtf8, encodeUtf8)
11import Network.HTTP.Client (defaultManagerSettings, httpLbs,
11import Network.HTTP.Client (defaultManagerSettings, httpLbs,
12− method, newManager, parseUrl)
12+ method, newManager, parseUrl,
13+ managerRawConnection)
13import Network.HTTP.Types (Query, encodePath,
14import Network.HTTP.Types (Query, encodePath,
14 encodePathSegments)
15 encodePathSegments)
15−
16+import Network.HTTP.Client.Internal (makeConnection)
17+import qualified Network.Socket as S
18+import qualified Network.Socket.ByteString as SBS
16import Docker.Types
19import Docker.Types
17
20
18-- The reason we return Maybe Request is because the parseURL function
21-- The reason we return Maybe Request is because the parseURL function
@@ -35,12 +38,33 @@ defaultHttpHandler request = do
35 response <- httpLbs request manager
38 response <- httpLbs request manager
36 return response
39 return response
37
40
41+-- | Connect to a unix domain socket (the default docker socket is
42+-- at \/var\/run\/docker.sock)
43+--
44+-- Docker seems to ignore the hostname in requests sent over unix domain
45+-- sockets (and the port obviously doesn't matter either)
46+unixHttpHandler :: FilePath -- ^ The socket to connect to
47+ -> HttpHandler IO
48+unixHttpHandler fp request= do
49+ let mSettings = defaultManagerSettings
50+ { managerRawConnection = return $ openUnixSocket fp}
51+ manager <- newManager mSettings
52+ httpLbs request manager
53+ where
54+ openUnixSocket filePath _ _ _ = do
55+ s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
56+ S.connect s (S.SockAddrUnix filePath)
57+ makeConnection (SBS.recv s 8096)
58+ (SBS.sendAll s)
59+ (S.sClose s)
60+
38encodeURL :: [Text] -> Text
61encodeURL :: [Text] -> Text
39encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps
62encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps
40
63
41encodeURLWithQuery :: [Text] -> Query -> Text
64encodeURLWithQuery :: [Text] -> Query -> Text
42encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q
65encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q
43
66
67+encodeQ :: String -> ByteString
44encodeQ = encodeUtf8 . T.pack
68encodeQ = encodeUtf8 . T.pack
45
69
46getEndpoint :: Endpoint -> Text
70getEndpoint :: Endpoint -> Text
@@ -74,4 +98,3 @@ getEndpoint (ContainerLogsEndpoint cid (LogOpts follow stdout stderr since times
74getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
98getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
75 encodeURLWithQuery ["containers", cid] query
99 encodeURLWithQuery ["containers", cid] query
76 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
100 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
77−