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