Add support for pulling images from private registries

Fixes denibertovic#82.

`pullImage` now takes a `PullOpts` argument, which includes an optional
`AuthConfig`. For more details, see:
https://docs.docker.com/engine/api/v1.41/#section/Authentication

docker.cabal

@@ -26,6 +26,7 @@ library
   -- other-modules:       Docker.Internal
   build-depends:       base >= 4.7 && < 5
                      , aeson >= 0.9.0 && < 2.0.0
+                     , base64-bytestring >= 1.0.0.0 && < 1.3.0.0
                      , blaze-builder >= 0.4.0 && < 0.5.0
                      , bytestring >= 0.10.0 && < 0.11.0
                      , containers >= 0.5.0 && < 0.7.0

src/Docker/Client/Api.hs

@@ -208,14 +208,11 @@ buildImageFromDockerfile opts base = do
 
 -- | Pulls an image from Docker Hub (by default).
 --
--- TODO: Add support for X-Registry-Auth and pulling from private docker
--- registries.
---
 -- TODO: Implement importImage function that uses he same
 -- CreateImageEndpoint but rather than pulling from docker hub it imports
 -- the image from a tarball or a URL.
-pullImage :: forall m b . (MonadIO m, MonadMask m) => T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)
-pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing)
+pullImage :: forall m b . (MonadIO m, MonadMask m) => PullOpts -> T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)
+pullImage opts name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing (pullAuthConfig opts))
 
 -- | Creates network
 createNetwork :: forall m. (MonadIO m, MonadMask m) => CreateNetworkOpts -> DockerT m (Either DockerError NetworkID)

src/Docker/Client/Http.hs

@@ -46,6 +46,7 @@ import qualified Network.Socket.ByteString    as SBS
 
 import           Docker.Client.Internal       (getEndpoint,
                                                getEndpointContentType,
+                                               getEndpointHeaders,
                                                getEndpointRequestBody)
 import           Docker.Client.Types          (DockerClientOpts, Endpoint (..),
                                                apiVer, baseUrl)
@@ -103,7 +104,8 @@ mkHttpRequest verb endpoint opts =
     -- Note: Do we need to set length header?
     setRequestFields request = request
       { method = HTTP.renderStdMethod verb
-      , requestHeaders = [("Content-Type", getEndpointContentType endpoint)]
+      , requestHeaders =
+          ("Content-Type", getEndpointContentType endpoint) : getEndpointHeaders endpoint
         -- This will either be a HTTP.RequestBodyLBS or
         -- HTTP.RequestBodySourceChunked for the build endpoint
       , requestBody =

src/Docker/Client/Internal.hs

@@ -1,17 +1,19 @@
 module Docker.Client.Internal where
 
-import           Blaze.ByteString.Builder (toByteString)
-import qualified Data.Aeson               as JSON
-import           Data.ByteString          (ByteString)
-import qualified Data.ByteString.Char8    as BSC
-import qualified Data.Conduit.Binary      as CB
-import qualified Data.Text                as T
-import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)
-import qualified Network.HTTP.Client      as HTTP
-import           Network.HTTP.Conduit     (requestBodySourceChunked)
-import           Network.HTTP.Types       (Query, encodePath,
-                                           encodePathSegments)
-import           Prelude                  hiding (all)
+import           Blaze.ByteString.Builder   (toByteString)
+import qualified Data.Aeson                 as JSON
+import           Data.ByteString            (ByteString)
+import qualified Data.ByteString.Base64.URL as Base64
+import qualified Data.ByteString.Char8      as BSC
+import qualified Data.ByteString.Lazy       as BL
+import qualified Data.Conduit.Binary        as CB
+import qualified Data.Text                  as T
+import           Data.Text.Encoding         (decodeUtf8, encodeUtf8)
+import qualified Network.HTTP.Client        as HTTP
+import           Network.HTTP.Conduit       (requestBodySourceChunked)
+import           Network.HTTP.Types         (Query, RequestHeaders, encodePath,
+                                             encodePathSegments)
+import           Prelude                    hiding (all)
 
 import           Docker.Client.Types
 
@@ -25,6 +27,9 @@ encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q
 encodeQ :: String -> ByteString
 encodeQ = encodeUtf8 . T.pack
 
+encodeAuthConfig :: AuthConfig -> ByteString
+encodeAuthConfig = Base64.encode . BL.toStrict . JSON.encode
+
 getEndpoint :: ApiVersion -> Endpoint -> T.Text
 getEndpoint v VersionEndpoint = encodeURL [v, "version"]
 getEndpoint v (ListContainersEndpoint (ListOpts all)) = encodeURLWithQuery [v, "containers", "json"] [("all", Just (encodeQ $ show all))]
@@ -71,7 +76,7 @@ getEndpoint v (BuildImageEndpoint o _) = encodeURLWithQuery [v, "build"] query
               rm = encodeQ $ show $ buildRemoveItermediate o
               forcerm = encodeQ $ show $ buildForceRemoveIntermediate o
               pull = encodeQ $ show $ buildPullParent o
-getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images", "create"] query
+getEndpoint v (CreateImageEndpoint name tag _ _) = encodeURLWithQuery [v, "images", "create"] query
         where query = [("fromImage", Just n), ("tag", Just t)]
               n = encodeQ $ T.unpack name
               t = encodeQ $ T.unpack tag
@@ -96,7 +101,7 @@ getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing
 getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
 
 getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp
-getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing
+getEndpointRequestBody (CreateImageEndpoint _ _ _ _) = Nothing
 getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing
 
 getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)
@@ -106,3 +111,6 @@ getEndpointContentType :: Endpoint -> BSC.ByteString
 getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"
 getEndpointContentType _ = BSC.pack "application/json; charset=utf-8"
 
+getEndpointHeaders :: Endpoint -> RequestHeaders
+getEndpointHeaders (CreateImageEndpoint _ _ _ (Just authConfig)) = [("X-Registry-Auth", encodeAuthConfig authConfig)]
+getEndpointHeaders _ = []

src/Docker/Client/Types.hs

@@ -36,6 +36,10 @@ module Docker.Client.Types (
     , CreateOpts(..)
     , BuildOpts(..)
     , defaultBuildOpts
+    , PullOpts(..)
+    , defaultPullOpts
+    , AuthConfig(..)
+    , Credentials(..)
     , defaultCreateOpts
     , DetachKeys(..)
     , StartOpts(..)
@@ -136,7 +140,7 @@ data Endpoint =
       | DeleteContainerEndpoint ContainerDeleteOpts ContainerID
       | InspectContainerEndpoint ContainerID
       | BuildImageEndpoint BuildOpts FilePath
-      | CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)
+      | CreateImageEndpoint T.Text Tag (Maybe T.Text) (Maybe AuthConfig) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)
       | DeleteImageEndpoint ImageDeleteOpts ImageID
       | CreateNetworkEndpoint CreateNetworkOpts
       | RemoveNetworkEndpoint NetworkID
@@ -803,6 +807,43 @@ data ImageDeleteOpts = ImageDeleteOpts deriving (Eq, Show)
 defaultImageDeleteOpts :: ImageDeleteOpts
 defaultImageDeleteOpts = ImageDeleteOpts
 
+data PullOpts = PullOpts {
+                pullAuthConfig :: Maybe AuthConfig -- ^ Optional authentication for a private docker registry
+              } deriving (Eq, Show)
+
+-- | Default options for pulling an image.
+defaultPullOpts :: PullOpts
+defaultPullOpts = PullOpts { pullAuthConfig = Nothing }
+
+-- | Authentication configuration for a private registry.
+--
+-- See <https://docs.docker.com/engine/api/v1.41/#section/Authentication>.
+data AuthConfig =
+    AuthCredentials Credentials
+  | IdentityToken Text
+  deriving (Eq, Show)
+
+instance ToJSON AuthConfig where
+  toJSON (AuthCredentials creds) = toJSON creds
+  toJSON (IdentityToken token)   = object ["identitytoken" .= token]
+
+-- | Authentication credentials
+data Credentials = Credentials {
+                   username      :: Text
+                 , password      :: Text
+                 , email         :: Text
+                 , serverAddress :: Text
+                 } deriving (Eq, Show, Generic)
+
+instance ToJSON Credentials where
+  toJSON creds =
+    object
+      [ "username" .= username creds
+      , "password" .= password creds
+      , "email" .= email creds
+      , "serveraddress" .= serverAddress creds
+      ]
+
 -- | Timestamp alias.
 type Timestamp = Integer