git.iko.soy/docker-hs
on master help sign in
Moves http related stuff into own module
8eee9baDeni Bertovic
docker.cabal+2−2
compare with master
unifiedsplit
@@ -17,8 +17,8 @@ stability: experimental
17library
17library
18 default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll
18 default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll
19 hs-source-dirs: src
19 hs-source-dirs: src
20− exposed-modules: Docker, Docker.Types, Docker.Internal
20+ exposed-modules: Docker, Docker.Types, Docker.Internal, Docker.Http
21− -- other-modules: Network.Docker.Internal
21+ -- other-modules: Docker.Internal
22 build-depends: base >= 4.7 && < 5
22 build-depends: base >= 4.7 && < 5
23 , lens
23 , lens
24 , aeson
24 , aeson
src/Docker.hs+1
@@ -14,6 +14,7 @@ import Data.Maybe (fromJust)
14import Network.HTTP.Client (responseBody)
14import Network.HTTP.Client (responseBody)
15import Network.HTTP.Types (StdMethod (..))
15import Network.HTTP.Types (StdMethod (..))
16
16
17+import Docker.Http
17import Docker.Internal
18import Docker.Internal
18import Docker.Types
19import Docker.Types
19
20
src/Docker/Http.hsnew file+68
@@ -0,0 +1,68 @@
1+module Docker.Http where
2+
3+import Control.Monad.Except (ExceptT, runExceptT)
4+import Control.Monad.Reader (ReaderT, runReaderT)
5+import qualified Data.ByteString.Lazy as BL
6+import Data.Text as T
7+import Data.Text.Encoding (encodeUtf8)
8+import Network.HTTP.Client (defaultManagerSettings, httpLbs,
9+ managerRawConnection, method, newManager,
10+ parseUrl)
11+import qualified Network.HTTP.Client as HTTP
12+import Network.HTTP.Types (StdMethod)
13+
14+import Docker.Internal (getEndpoint)
15+import Docker.Types (DockerClientOpts, Endpoint, baseUrl)
16+
17+type Request = HTTP.Request
18+type Response = HTTP.Response BL.ByteString
19+type HttpVerb = StdMethod
20+type HttpHandler m = Request -> m Response
21+
22+type DockerT m a = ReaderT (DockerClientOpts, HttpHandler m) (ExceptT String m) a
23+
24+runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m (Either String a)
25+runDockerT (opts, h) r = runExceptT $ runReaderT r (opts, h)
26+
27+
28+-- The reason we return Maybe Request is because the parseURL function
29+-- might find out parameters are invalid and will fail to build a Request
30+-- Since we are the ones building the Requests this shouldn't happen, but would
31+-- benefit from testing that on all of our Endpoints
32+mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
33+mkHttpRequest verb e opts = request
34+ where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint e)
35+ initialR = parseUrl fullE
36+ request = case initialR of
37+ Just ir -> return $ ir { method = (encodeUtf8 . T.pack $ show verb) } -- , requestBody = RequestBodyLBS $ encode requestObject }
38+ Nothing -> Nothing
39+ -- TODO: manager = newManager defaultManagerSettings -- We likely need
40+ -- this for TLS.
41+
42+defaultHttpHandler :: HttpHandler IO
43+defaultHttpHandler request = do
44+ manager <- newManager defaultManagerSettings
45+ response <- httpLbs request manager
46+ return response
47+
48+-- | Connect to a unix domain socket (the default docker socket is
49+-- at \/var\/run\/docker.sock)
50+--
51+-- Docker seems to ignore the hostname in requests sent over unix domain
52+-- sockets (and the port obviously doesn't matter either)
53+unixHttpHandler :: FilePath -- ^ The socket to connect to
54+ -> HttpHandler IO
55+unixHttpHandler fp request= do
56+ let mSettings = defaultManagerSettings
57+ { managerRawConnection = return $ openUnixSocket fp}
58+ manager <- newManager mSettings
59+ httpLbs request manager
60+ where
61+ openUnixSocket filePath _ _ _ = do
62+ s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
63+ S.connect s (S.SockAddrUnix filePath)
64+ makeConnection (SBS.recv s 8096)
65+ (SBS.sendAll s)
66+ (S.sClose s)
67+
68+
src/Docker/Internal.hs+10−54
@@ -1,62 +1,18 @@
1module Docker.Internal where
1module Docker.Internal where
2
2
3
3
4−import Blaze.ByteString.Builder (toByteString)
4+import Blaze.ByteString.Builder (toByteString)
5−import Data.ByteString as BS
5+import Data.ByteString (ByteString)
6−import Data.ByteString (ByteString)
7import Data.Maybe
6import Data.Maybe
8−import Data.Text as T
7+import Data.Text as T
9−import Data.Text (Text)
8+import Data.Text (Text)
10−import Data.Text.Encoding (decodeUtf8, encodeUtf8)
9+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
11−import Network.HTTP.Client (defaultManagerSettings, httpLbs,
12− method, newManager, parseUrl,
13− managerRawConnection)
14−import Network.HTTP.Types (Query, encodePath,
15− encodePathSegments)
16−import Network.HTTP.Client.Internal (makeConnection)
17−import qualified Network.Socket as S
18−import qualified Network.Socket.ByteString as SBS
19import Docker.Types
10import Docker.Types
20−
11+import Network.HTTP.Client.Internal (makeConnection)
21−-- The reason we return Maybe Request is because the parseURL function
12+import Network.HTTP.Types (Query, encodePath,
22−-- might find out parameters are invalid and will fail to build a Request
13+ encodePathSegments)
23−-- Since we are the ones building the Requests this shouldn't happen, but would
14+import qualified Network.Socket as S
24−-- benefit from testing that on all of our Endpoints
15+import qualified Network.Socket.ByteString as SBS
25−mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
26−mkHttpRequest verb e opts = request
27− where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint e)
28− initialR = parseUrl fullE
29− request = case initialR of
30− Just ir -> return $ ir { method = (encodeUtf8 . T.pack $ show verb) } -- , requestBody = RequestBodyLBS $ encode requestObject }
31− Nothing -> Nothing
32− -- TODO: manager = newManager defaultManagerSettings -- We likely need
33− -- this for TLS.
34−
35−defaultHttpHandler :: HttpHandler IO
36−defaultHttpHandler request = do
37− manager <- newManager defaultManagerSettings
38− response <- httpLbs request manager
39− return response
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
16
61encodeURL :: [Text] -> Text
17encodeURL :: [Text] -> Text
62encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps
18encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps
src/Docker/Types.hs+11−30
@@ -1,25 +1,16 @@
1module Docker.Types where
1module Docker.Types where
2
2
3−import Control.Monad (mzero)
4−import Control.Monad.Catch
5−import Control.Monad.Except (ExceptT, runExceptT)
6−import Control.Monad.Reader (ReaderT, runReaderT)
7−import Data.Aeson (FromJSON, ToJSON, decode, encode,
3+import Data.Aeson (FromJSON, ToJSON, decode, encode,
8− genericParseJSON, genericToJSON, object,
4+ genericParseJSON, genericToJSON, object,
9− parseJSON, toJSON, (.:), (.:?), (.=))
5+ parseJSON, toJSON, (.:), (.:?), (.=))
10−import qualified Data.Aeson as JSON
6+import qualified Data.Aeson as JSON
11−import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
7+import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
12−import qualified Data.ByteString.Lazy as BL
13−import Data.Char (toUpper)
8+import Data.Char (toUpper)
14−import qualified Data.Map as M
9+import qualified Data.Map as M
15−import Data.Text (Text)
10+import Data.Text (Text)
16−import qualified Data.Text as T
11+import qualified Data.Text as T
17−import GHC.Generics (Generic)
12+import GHC.Generics (Generic)
18−import qualified Network.HTTP.Client as HTTP
19−import Network.HTTP.Types (StdMethod)
20−import Prelude hiding (all, tail)
13+import Prelude hiding (all, tail)
21−
22−type HttpVerb = StdMethod
23
14
24data Endpoint =
15data Endpoint =
25 VersionEndpoint
16 VersionEndpoint
@@ -42,9 +33,6 @@ type ImageID = Text
42
33
43data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
34data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
44
35
45−type Request = HTTP.Request
46−type Response = HTTP.Response BL.ByteString
47−
48-- TODO: Add more Signals or use an existing lib
36-- TODO: Add more Signals or use an existing lib
49data Signal = SIGHUP
37data Signal = SIGHUP
50 | SIGINT
38 | SIGINT
@@ -60,13 +48,6 @@ data DockerClientOpts = DockerClientOpts {
60 , baseUrl :: URL
48 , baseUrl :: URL
61 }
49 }
62
50
63−type HttpHandler m = Request -> m Response
64−
65−type DockerT m a = ReaderT (DockerClientOpts, HttpHandler m) (ExceptT String m) a
66−
67−runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m (Either String a)
68−runDockerT (opts, h) r = runExceptT $ runReaderT r (opts, h)
69−
70data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
51data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
71
52
72defaultListOpts = ListOpts { all=False }
53defaultListOpts = ListOpts { all=False }