git.iko.soy/docker-hs
on master help sign in
Moves http related stuff into own module
commit8eee9ba9c6543ad4c02bff85ea8a2ee3da5cfc45 authorDeni Bertovic <deni@denibertovic.com> dateFri 8 Apr 2016, 15:26 (11 years ago) parentb0cb71e
5 files changed+92−86
compare with master
unifiedsplit
docker.cabal+2−2 src/Docker.hs+1 src/Docker/Http.hs+68 src/Docker/Internal.hs+10−54 src/Docker/Types.hs+11−30
docker.cabal+2−2
@@ -17,8 +17,8 @@ stability: experimental
1717library
1818 default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll
1919 hs-source-dirs: src
20− exposed-modules: Docker, Docker.Types, Docker.Internal
21− -- other-modules: Network.Docker.Internal
20+ exposed-modules: Docker, Docker.Types, Docker.Internal, Docker.Http
21+ -- other-modules: Docker.Internal
2222 build-depends: base >= 4.7 && < 5
2323 , lens
2424 , aeson
src/Docker.hs+1
@@ -14,6 +14,7 @@ import Data.Maybe (fromJust)
1414import Network.HTTP.Client (responseBody)
1515import Network.HTTP.Types (StdMethod (..))
1616
17+import Docker.Http
1718import Docker.Internal
1819import Docker.Types
1920
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 @@
11module Docker.Internal where
22
33
4−import Blaze.ByteString.Builder (toByteString)
5−import Data.ByteString as BS
6−import Data.ByteString (ByteString)
4+import Blaze.ByteString.Builder (toByteString)
5+import Data.ByteString (ByteString)
76import Data.Maybe
8−import Data.Text as T
9−import Data.Text (Text)
10−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
7+import Data.Text as T
8+import Data.Text (Text)
9+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
1910import Docker.Types
20−
21−-- The reason we return Maybe Request is because the parseURL function
22−-- might find out parameters are invalid and will fail to build a Request
23−-- Since we are the ones building the Requests this shouldn't happen, but would
24−-- benefit from testing that on all of our Endpoints
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)
11+import Network.HTTP.Client.Internal (makeConnection)
12+import Network.HTTP.Types (Query, encodePath,
13+ encodePathSegments)
14+import qualified Network.Socket as S
15+import qualified Network.Socket.ByteString as SBS
6016
6117encodeURL :: [Text] -> Text
6218encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps
src/Docker/Types.hs+11−30
@@ -1,25 +1,16 @@
11module Docker.Types where
22
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,
8− genericParseJSON, genericToJSON, object,
9− parseJSON, toJSON, (.:), (.:?), (.=))
10−import qualified Data.Aeson as JSON
11−import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
12−import qualified Data.ByteString.Lazy as BL
13−import Data.Char (toUpper)
14−import qualified Data.Map as M
15−import Data.Text (Text)
16−import qualified Data.Text as T
17−import GHC.Generics (Generic)
18−import qualified Network.HTTP.Client as HTTP
19−import Network.HTTP.Types (StdMethod)
20−import Prelude hiding (all, tail)
21−
22−type HttpVerb = StdMethod
3+import Data.Aeson (FromJSON, ToJSON, decode, encode,
4+ genericParseJSON, genericToJSON, object,
5+ parseJSON, toJSON, (.:), (.:?), (.=))
6+import qualified Data.Aeson as JSON
7+import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
8+import Data.Char (toUpper)
9+import qualified Data.Map as M
10+import Data.Text (Text)
11+import qualified Data.Text as T
12+import GHC.Generics (Generic)
13+import Prelude hiding (all, tail)
2314
2415data Endpoint =
2516 VersionEndpoint
@@ -42,9 +33,6 @@ type ImageID = Text
4233
4334data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
4435
45−type Request = HTTP.Request
46−type Response = HTTP.Response BL.ByteString
47−
4836-- TODO: Add more Signals or use an existing lib
4937data Signal = SIGHUP
5038 | SIGINT
@@ -60,13 +48,6 @@ data DockerClientOpts = DockerClientOpts {
6048 , baseUrl :: URL
6149 }
6250
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−
7051data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
7152
7253defaultListOpts = ListOpts { all=False }