Merge pull request #24 from hadolint/parse-registry-name

Parsing the registry url in image names

src/Language/Docker.hs

@@ -70,7 +70,8 @@ module Language.Docker
     , Language.Docker.Syntax.AddArgs(..)
     , Language.Docker.Syntax.Check(..)
     , Language.Docker.Syntax.CheckArgs(..)
-    , Language.Docker.Syntax.Image
+    , Language.Docker.Syntax.Image(..)
+    , Language.Docker.Syntax.Registry(..)
     , Language.Docker.Syntax.ImageAlias(..)
     , Language.Docker.Syntax.Tag
     , Language.Docker.Syntax.Ports

src/Language/Docker/EDSL.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Language.Docker.EDSL where
@@ -10,6 +11,7 @@ import Control.Monad.Trans.Free (FreeT, iterTM)
 import Control.Monad.Writer
 import Data.ByteString (ByteString)
 import Data.List.NonEmpty (NonEmpty)
+import Data.String (fromString)
 
 import qualified Language.Docker.PrettyPrint as PrettyPrint
 import qualified Language.Docker.Syntax as Syntax
@@ -99,13 +101,13 @@ toDockerfileStr :: EDockerfileM a -> String
 toDockerfileStr = PrettyPrint.prettyPrint . toDockerfile
 
 untagged :: String -> EBaseImage
-untagged = flip EUntaggedImage Nothing
+untagged = flip EUntaggedImage Nothing . fromString
 
 tagged :: String -> String -> EBaseImage
-tagged imageName tag = ETaggedImage imageName tag Nothing
+tagged imageName tag = ETaggedImage (fromString imageName) tag Nothing
 
 digested :: String -> ByteString -> EBaseImage
-digested imageName hash = EDigestedImage imageName hash Nothing
+digested imageName hash = EDigestedImage (fromString imageName) hash Nothing
 
 aliased :: EBaseImage -> String -> EBaseImage
 aliased image alias =

src/Language/Docker/EDSL/Types.hs

@@ -8,18 +8,18 @@ import Data.String
 import qualified Language.Docker.Syntax as Syntax
 
 data EBaseImage
-    = EUntaggedImage String
+    = EUntaggedImage Syntax.Image
                      (Maybe Syntax.ImageAlias)
-    | ETaggedImage String
+    | ETaggedImage Syntax.Image
                    String
                    (Maybe Syntax.ImageAlias)
-    | EDigestedImage String
+    | EDigestedImage Syntax.Image
                      ByteString
                      (Maybe Syntax.ImageAlias)
     deriving (Show, Eq, Ord)
 
 instance IsString EBaseImage where
-    fromString = flip EUntaggedImage Nothing
+    fromString = flip EUntaggedImage Nothing . fromString
 
 data EInstruction next
     = From EBaseImage
@@ -57,7 +57,8 @@ data EInstruction next
                  next
     | Env Syntax.Pairs
           next
-    | Arg String (Maybe String)
+    | Arg String
+          (Maybe String)
           next
     | Comment String
               next

src/Language/Docker/Parser.hs

@@ -32,29 +32,37 @@ comment = do
     text <- many (noneOf "\n")
     return $ Comment text
 
+registry :: Parser Registry
+registry = do
+    name <- many1 (noneOf "\t\n /")
+    void $ char '/'
+    return $ Registry name
+
 taggedImage :: Parser BaseImage
 taggedImage = do
+    registryName <- (Just <$> try registry) <|> return Nothing
     name <- many (noneOf "\t\n: ")
     void $ char ':'
     tag <- many1 (noneOf "\t\n: ")
     maybeAlias <- maybeImageAlias
-    return $ TaggedImage name tag maybeAlias
+    return $ TaggedImage (Image registryName name) tag maybeAlias
 
 digestedImage :: Parser BaseImage
 digestedImage = do
     name <- many (noneOf "\t\n@ ")
     void $ char '@'
     digest <- many1 (noneOf "\t\n@ ")
     maybeAlias <- maybeImageAlias
-    return $ DigestedImage name (pack digest) maybeAlias
+    return $ DigestedImage (Image Nothing name) (pack digest) maybeAlias
 
 untaggedImage :: Parser BaseImage
 untaggedImage = do
+    registryName <- (Just <$> try registry) <|> return Nothing
     name <- many (noneOf "\n\t:@ ")
     notInvalidTag name
     notInvalidDigest name
     maybeAlias <- maybeImageAlias
-    return $ UntaggedImage name maybeAlias
+    return $ UntaggedImage (Image registryName name) maybeAlias
   where
     notInvalidTag :: String -> Parser ()
     notInvalidTag name =

src/Language/Docker/PrettyPrint.hs

@@ -29,19 +29,23 @@ prettyPrint =
 prettyPrintInstructionPos :: InstructionPos -> String
 prettyPrintInstructionPos (InstructionPos i _ _) = render (prettyPrintInstruction i)
 
+prettyPrintImage :: Image -> Doc
+prettyPrintImage (Image Nothing name) = text name
+prettyPrintImage (Image (Just (Registry reg)) name) = text reg <> char '/' <> text name
+
 prettyPrintBaseImage :: BaseImage -> Doc
 prettyPrintBaseImage b =
     case b of
-        DigestedImage name digest alias -> do
-            text name
+        DigestedImage img digest alias -> do
+            prettyPrintImage img
             char '@'
             text (ByteString.unpack digest)
             prettyAlias alias
-        UntaggedImage name alias -> do
+        UntaggedImage (Image _ name) alias -> do
             text name
             prettyAlias alias
-        TaggedImage name tag alias -> do
-            text name
+        TaggedImage img tag alias -> do
+            prettyPrintImage img
             char ':'
             text tag
             prettyAlias alias

src/Language/Docker/Syntax.hs

@@ -4,12 +4,30 @@
 module Language.Docker.Syntax where
 
 import Data.ByteString.Char8 (ByteString)
+import Data.List (intercalate, isInfixOf)
 import Data.List.NonEmpty (NonEmpty)
-import Data.String (IsString)
+import Data.List.Split (endBy)
+import Data.String (IsString(..))
 import Data.Time.Clock (DiffTime)
 import GHC.Exts (IsList(..))
 
-type Image = String
+data Image = Image
+    { registryName :: Maybe Registry
+    , imageName :: String
+    } deriving (Show, Eq, Ord)
+
+instance IsString Image where
+    fromString img =
+        if "/" `isInfixOf` img
+            then let parts = endBy "/" img
+                 in case parts of
+                        registry:rest -> Image (Just (Registry registry)) (intercalate "/" rest)
+                        _ -> Image Nothing img
+            else Image Nothing img
+
+newtype Registry =
+    Registry String
+    deriving (Show, Eq, Ord, IsString)
 
 type Tag = String
 

src/Language/Docker/Syntax/Lift.hs

@@ -23,6 +23,10 @@ deriveLift ''Port
 
 deriveLift ''Ports
 
+deriveLift ''Registry
+
+deriveLift ''Image
+
 deriveLift ''ImageAlias
 
 deriveLift ''BaseImage

test/Language/Docker/ParserSpec.hs

@@ -39,6 +39,14 @@ spec = do
             it "parse diggested image" $
                 assertAst "FROM ubuntu@sha256:0ef2e08ed3fab AS foo" [From (DigestedImage "ubuntu" "sha256:0ef2e08ed3fab" (Just $ ImageAlias "foo"))]
 
+        describe "parse FROM with registry" $ do
+            it "registry without port" $
+                assertAst "FROM foo.com/node" [From (UntaggedImage (Image (Just "foo.com") "node") Nothing)]
+            it "parse with port and tag" $
+                assertAst
+                "FROM myregistry.com:5000/imagename:5.12-dev"
+                [From (TaggedImage (Image (Just "myregistry.com:5000") "imagename") "5.12-dev" Nothing)]
+
         describe "parse LABEL" $ do
             it "parse label" $ assertAst "LABEL foo=bar" [Label[("foo", "bar")]]
             it "parse space separated label" $ assertAst "LABEL foo bar baz" [Label[("foo", "bar baz")]]
@@ -137,7 +145,7 @@ spec = do
                 "HEALTHCHECK --interval=5m \\\nCMD curl -f http://localhost/"
                 [Healthcheck $
                     Check $
-                      CheckArgs (words "curl -f http://localhost/") (Just $ fromInteger 300) Nothing Nothing Nothing
+                      CheckArgs (words "curl -f http://localhost/") (Just 300) Nothing Nothing Nothing
                 ]
 
             it "parse healthcheck with retries" $
@@ -153,15 +161,15 @@ spec = do
                 "HEALTHCHECK --timeout=10s CMD curl -f http://localhost/"
                 [Healthcheck $
                     Check $
-                      CheckArgs (words "curl -f http://localhost/") Nothing (Just $ fromInteger 10) Nothing Nothing
+                      CheckArgs (words "curl -f http://localhost/") Nothing (Just 10) Nothing Nothing
                 ]
 
             it "parse healthcheck with start-period" $
               assertAst
                 "HEALTHCHECK --start-period=2m CMD curl -f http://localhost/"
                 [Healthcheck $
                     Check $
-                      CheckArgs (words "curl -f http://localhost/") Nothing Nothing (Just $ fromInteger 120) Nothing
+                      CheckArgs (words "curl -f http://localhost/") Nothing Nothing (Just 120) Nothing
                 ]
 
             it "parse healthcheck with all flags" $
@@ -171,9 +179,9 @@ spec = do
                     Check $
                       CheckArgs
                         (words "curl -f http://localhost/")
-                        (Just $ fromInteger 5)
-                        (Just $ fromInteger 60)
-                        (Just $ fromInteger 2)
+                        (Just 5)
+                        (Just 60)
+                        (Just 2)
                         (Just $ Retries 3)
                 ]