git.iko.soy/docker-hs
on 201fe06 help sign in
docker-hs/src/Docker/Client/Http.hs
233 lines 9.8 kB history raw
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE ScopedTypeVariables #-}
4module Docker.Client.Http where
6import Control.Monad.Reader (ReaderT, runReaderT)
7import qualified Data.ByteString.Char8 as BSC
8import qualified Data.ByteString.Lazy as BL
9import Data.Default.Class (def)
10import Data.Monoid ((<>))
11import Data.Text.Encoding (encodeUtf8)
12import Data.X509 (CertificateChain (..))
13import Data.X509.CertificateStore (makeCertificateStore)
14import Data.X509.File (readKeyFile, readSignedObject)
15import Network.HTTP.Client (defaultManagerSettings, httpLbs,
16 managerRawConnection, method,
17 newManager, parseUrl,
18 requestBody, requestHeaders)
19import qualified Network.HTTP.Client as HTTP
20import Network.HTTP.Client.Internal (makeConnection)
21import Network.HTTP.Types (StdMethod, status101, status200,
22 status201, status204)
23import Network.TLS (ClientHooks (..),
24 ClientParams (..), Shared (..),
25 Supported (..),
26 defaultParamsClient)
27import Network.TLS.Extra (ciphersuite_strong)
28import System.X509 (getSystemCertificateStore)
30import Control.Exception (try)
31import Control.Monad.Except
32import Control.Monad.Reader.Class
33import Data.Text as T
34import Data.Typeable (Typeable)
35import qualified Network.HTTP.Types as HTTP
36import qualified Network.Socket as S
37import qualified Network.Socket.ByteString as SBS
40import Docker.Client.Internal (getEndpoint,
41 getEndpointRequestBody)
42import Docker.Client.Types (DockerClientOpts, Endpoint (..),
43 baseUrl)
45type Request = HTTP.Request
46type Response = HTTP.Response BL.ByteString
47type HttpVerb = StdMethod
48type HttpHandler m = Request -> m (Either DockerError Response)
50data DockerError = DockerConnectionError
51 | DockerInvalidRequest Endpoint
52 | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.
53 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.
54 | GenericDockerError Text deriving (Eq, Show, Typeable)
56newtype DockerT m a = DockerT {
57 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
58 } deriving (Functor) -- Applicative, Monad, MonadReader, MonadError, MonadTrans
60instance Applicative m => Applicative (DockerT m) where
61 pure a = DockerT $ pure a
62 (<*>) (DockerT f) (DockerT v) = DockerT $ f <*> v
64instance Monad m => Monad (DockerT m) where
65 (DockerT m) >>= f = DockerT $ m >>= unDockerT . f
66 return = pure
68instance Monad m => MonadReader (DockerClientOpts, HttpHandler m) (DockerT m) where
69 ask = DockerT ask
70 local f (DockerT m) = DockerT $ local f m
72instance MonadTrans DockerT where
73 lift m = DockerT $ lift m
75instance MonadIO m => MonadIO (DockerT m) where
76 liftIO = lift . liftIO
78runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
79runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
81-- The reason we return Maybe Request is because the parseURL function
82-- might find out parameters are invalid and will fail to build a Request
83-- Since we are the ones building the Requests this shouldn't happen, but would
84-- benefit from testing that on all of our Endpoints
85mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
86mkHttpRequest verb e opts = request
87 where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint e)
88 initialR = parseUrl fullE
89 request' = case initialR of
90 Just ir ->
91 return $ ir {method = (encodeUtf8 . T.pack $ show verb),
92 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}
93 Nothing -> Nothing
94 request = (\r -> maybe r (\body -> r {requestBody = HTTP.RequestBodyLBS body,
95 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
96 -- Note: Do we need to set length header?
98defaultHttpHandler :: MonadIO m => HttpHandler m
99defaultHttpHandler request = do
100 manager <- liftIO $ newManager defaultManagerSettings
101 httpHandler manager request
103httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m
104httpHandler manager request = liftIO $ do
105 try (httpLbs request manager) >>= \res -> case res of
106 Right res -> return $ Right res
107 Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
108 Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
109 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
111-- | Connect to a unix domain socket (the default docker socket is
112-- at \/var\/run\/docker.sock)
113--
114-- Docker seems to ignore the hostname in requests sent over unix domain
115-- sockets (and the port obviously doesn't matter either)
116unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to
117 -> HttpHandler m
118unixHttpHandler fp request = do
119 let mSettings = defaultManagerSettings
120 { managerRawConnection = return $ openUnixSocket fp}
121 manager <- liftIO $ newManager mSettings
122 httpHandler manager request
124 where
125 openUnixSocket filePath _ _ _ = do
126 s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
127 S.connect s (S.SockAddrUnix filePath)
128 makeConnection (SBS.recv s 8096)
129 (SBS.sendAll s)
130 (S.sClose s)
132-- TODO:
133-- Move this to http-client-tls or network?
134-- Add CA.
135-- Maybe change this to: HostName -> PortNumber -> ClientParams -> IO (Either String TLSSettings)
136clientParamsWithClientAuthentication :: S.HostName -> S.PortNumber -> FilePath -> FilePath -> IO (Either String ClientParams)
137clientParamsWithClientAuthentication host port keyFile certificateFile = do
138 keys <- readKeyFile keyFile
139 cert <- readSignedObject certificateFile
140 case keys of
141 [key] ->
142 -- TODO: load keys/path from file
143 let params = (defaultParamsClient host $ BSC.pack $ show port) {
144 clientHooks = def
145 { onCertificateRequest = \_ -> return (Just (CertificateChain cert, key))}
146 , clientSupported = def
147 { supportedCiphers = ciphersuite_strong}
148 }
149 in
150 return $ Right params
151 _ ->
152 return $ Left $ "Could not read key file: " ++ keyFile
154clientParamsSetCA :: ClientParams -> FilePath -> IO ClientParams
155clientParamsSetCA params path = do
156 userStore <- makeCertificateStore <$> readSignedObject path
157 systemStore <- getSystemCertificateStore
158 let store = userStore <> systemStore
159 let oldShared = clientShared params
160 return $ params { clientShared = oldShared
161 { sharedCAStore = store }
162 }
165-- If the status is an error, returns a Just DockerError. Otherwise, returns Nothing.
166statusCodeToError :: Endpoint -> HTTP.Status -> Maybe DockerError
167statusCodeToError VersionEndpoint st =
168 if st == status200 then
169 Nothing
170 else
171 Just $ DockerInvalidStatusCode st
172statusCodeToError (ListContainersEndpoint _) st =
173 if st == status200 then
174 Nothing
175 else
176 Just $ DockerInvalidStatusCode st
177statusCodeToError (ListImagesEndpoint _) st =
178 if st == status200 then
179 Nothing
180 else
181 Just $ DockerInvalidStatusCode st
182statusCodeToError (CreateContainerEndpoint _) st =
183 if st == status201 then
184 Nothing
185 else
186 Just $ DockerInvalidStatusCode st
187statusCodeToError (StartContainerEndpoint _ _) st =
188 if st == status204 then
189 Nothing
190 else
191 Just $ DockerInvalidStatusCode st
192statusCodeToError (StopContainerEndpoint _ _) st =
193 if st == status204 then
194 Nothing
195 else
196 Just $ DockerInvalidStatusCode st
197statusCodeToError (KillContainerEndpoint _ _) st =
198 if st == status204 then
199 Nothing
200 else
201 Just $ DockerInvalidStatusCode st
202statusCodeToError (RestartContainerEndpoint _ _) st =
203 if st == status204 then
204 Nothing
205 else
206 Just $ DockerInvalidStatusCode st
207statusCodeToError (PauseContainerEndpoint _) st =
208 if st == status204 then
209 Nothing
210 else
211 Just $ DockerInvalidStatusCode st
212statusCodeToError (UnpauseContainerEndpoint _) st =
213 if st == status204 then
214 Nothing
215 else
216 Just $ DockerInvalidStatusCode st
217statusCodeToError (ContainerLogsEndpoint _ _ _) st =
218 if st == status200 || st == status101 then
219 Nothing
220 else
221 Just $ DockerInvalidStatusCode st
222statusCodeToError (DeleteContainerEndpoint _ _) st =
223 if st == status204 then
224 Nothing
225 else
226 Just $ DockerInvalidStatusCode st
227statusCodeToError (InspectContainerEndpoint _) st =
228 if st == status200 then
229 Nothing
230 else
231 Just $ DockerInvalidStatusCode st