Syntax.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}

module Language.Docker.Syntax
  ( module Language.Docker.Syntax,
    module Language.Docker.Syntax.Port,
    module Language.Docker.Syntax.PortRange,
    module Language.Docker.Syntax.Protocol
  )
where

import Data.Default.Class (Default (..))
import Data.List (intercalate, isInfixOf)
import Data.List.NonEmpty (NonEmpty)
import Data.List.Split (endBy)
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Set (Set)
import qualified Data.Text as Text
import Data.Time.Clock (DiffTime)
import GHC.Exts (IsList (..))
import Text.Printf


import Language.Docker.Syntax.Port
import Language.Docker.Syntax.PortRange
import Language.Docker.Syntax.Protocol


data Image
  = Image
      { registryName :: !(Maybe Registry),
        imageName :: !Text
      }
  deriving (Show, Eq, Ord)

instance IsString Image where
  fromString img =
    if "/" `isInfixOf` img
      then
        let parts = endBy "/" img
         in if "." `isInfixOf` head parts
              then
                Image
                  (Just (Registry (Text.pack (head parts))))
                  (Text.pack . intercalate "/" $ tail parts)
              else Image Nothing (Text.pack img)
      else Image Nothing (Text.pack img)

newtype Registry
  = Registry
      { unRegistry :: Text
      }
  deriving (Show, Eq, Ord, IsString)

newtype Tag
  = Tag
      { unTag :: Text
      }
  deriving (Show, Eq, Ord, IsString)

newtype Digest
  = Digest
      { unDigest :: Text
      }
  deriving (Show, Eq, Ord, IsString)

data PortSpec
  = PortSpec !Port
  | PortRangeSpec !PortRange
  deriving (Show, Eq, Ord)

newtype Ports
  = Ports
      { unPorts :: [PortSpec]
      }
  deriving (Show, Eq, Ord)

instance IsList Ports where
  type Item Ports = PortSpec
  fromList = Ports
  toList (Ports ps) = ps

type Directory = Text

type Platform = Text

newtype ImageAlias
  = ImageAlias
      { unImageAlias :: Text
      }
  deriving (Show, Eq, Ord, IsString)

data BaseImage
  = BaseImage
      { image :: !Image,
        tag :: !(Maybe Tag),
        digest :: !(Maybe Digest),
        alias :: !(Maybe ImageAlias),
        platform :: !(Maybe Platform)
      }
  deriving (Eq, Ord, Show)

-- | Type of the Dockerfile AST
type Dockerfile = [InstructionPos Text]

newtype SourcePath
  = SourcePath
      { unSourcePath :: Text
      }
  deriving (Show, Eq, Ord, IsString)

newtype TargetPath
  = TargetPath
      { unTargetPath :: Text
      }
  deriving (Show, Eq, Ord, IsString)

data Chown
  = Chown !Text
  | NoChown
  deriving (Show, Eq, Ord)

instance IsString Chown where
  fromString ch =
    case ch of
      "" -> NoChown
      _ -> Chown (Text.pack ch)

data Chmod
  = Chmod !Text
  | NoChmod
  deriving (Show, Eq, Ord)

instance IsString Chmod where
  fromString ch =
    case ch of
      "" -> NoChmod
      _ -> Chmod (Text.pack ch)

data Link
  = Link
  | NoLink
  deriving (Show, Eq, Ord)

data CopySource
  = CopySource !Text
  | NoSource
  deriving (Show, Eq, Ord)

instance IsString CopySource where
  fromString src =
    case src of
      "" -> NoSource
      _ -> CopySource (Text.pack src)

newtype Duration
  = Duration
      { durationTime :: DiffTime
      }
  deriving (Show, Eq, Ord, Num, Fractional)

newtype Retries
  = Retries
      { times :: Int
      }
  deriving (Show, Eq, Ord, Num)

data CopyArgs
  = CopyArgs
      { sourcePaths :: NonEmpty SourcePath,
        targetPath :: !TargetPath
      }
  deriving (Show, Eq, Ord)

data CopyFlags
  = CopyFlags
      { chownFlag :: !Chown,
        chmodFlag :: !Chmod,
        linkFlag :: !Link,
        sourceFlag :: !CopySource
      }
  deriving (Show, Eq, Ord)

instance Default CopyFlags where
  def = CopyFlags NoChown NoChmod NoLink NoSource

data AddArgs
  = AddArgs
      { sourcePaths :: NonEmpty SourcePath,
        targetPath :: !TargetPath
      }
  deriving (Show, Eq, Ord)

data AddFlags
  = AddFlags
      { chownFlag :: !Chown,
        chmodFlag :: !Chmod,
        linkFlag :: !Link
      }
  deriving (Show, Eq, Ord)

instance Default AddFlags where
  def = AddFlags NoChown NoChmod NoLink

data Check args
  = Check !(CheckArgs args)
  | NoCheck
  deriving (Show, Eq, Ord, Functor)

data Arguments args
  = ArgumentsText args
  | ArgumentsList args
  deriving (Show, Eq, Ord, Functor)

instance IsString (Arguments Text) where
  fromString = ArgumentsText . Text.pack

instance IsList (Arguments Text) where
  type Item (Arguments Text) = Text
  fromList = ArgumentsList . Text.unwords
  toList (ArgumentsText ps) = Text.words ps
  toList (ArgumentsList ps) = Text.words ps

data CheckArgs args
  = CheckArgs
      { checkCommand :: !(Arguments args),
        interval :: !(Maybe Duration),
        timeout :: !(Maybe Duration),
        startPeriod :: !(Maybe Duration),
        retries :: !(Maybe Retries)
      }
  deriving (Show, Eq, Ord, Functor)

type Pairs = [(Text, Text)]

data RunMount
  = BindMount !BindOpts
  | CacheMount !CacheOpts
  | TmpfsMount !TmpOpts
  | SecretMount !SecretOpts
  | SshMount !SecretOpts
  deriving (Eq, Show, Ord)

data BindOpts
  = BindOpts
      { bTarget :: !TargetPath,
        bSource :: !(Maybe SourcePath),
        bFromImage :: !(Maybe Text),
        bReadOnly :: !(Maybe Bool)
      }
  deriving (Show, Eq, Ord)

instance Default BindOpts where
  def = BindOpts "" Nothing Nothing Nothing

data CacheOpts
  = CacheOpts
      { cTarget :: !TargetPath,
        cSharing :: !(Maybe CacheSharing),
        cCacheId :: !(Maybe Text),
        cReadOnly :: !(Maybe Bool),
        cFromImage :: !(Maybe Text),
        cSource :: !(Maybe SourcePath),
        cMode :: !(Maybe Text),
        cUid :: !(Maybe Text),
        cGid :: !(Maybe Text)
      }
  deriving (Show, Eq, Ord)

instance Default CacheOpts where
  def = CacheOpts "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing

newtype TmpOpts = TmpOpts {tTarget :: TargetPath} deriving (Eq, Show, Ord)

instance Default TmpOpts where
  def = TmpOpts ""

data SecretOpts
  = SecretOpts
      { sTarget :: !(Maybe TargetPath),
        sCacheId :: !(Maybe Text),
        sIsRequired :: !(Maybe Bool),
        sSource :: !(Maybe SourcePath),
        sMode :: !(Maybe Text),
        sUid :: !(Maybe Text),
        sGid :: !(Maybe Text)
      }
  deriving (Eq, Show, Ord)

instance Default SecretOpts where
  def = SecretOpts Nothing Nothing Nothing Nothing Nothing Nothing Nothing

data CacheSharing
  = Shared
  | Private
  | Locked
  deriving (Show, Eq, Ord)

data RunSecurity
  = Insecure
  | Sandbox
  deriving (Show, Eq, Ord)

data RunNetwork
  = NetworkNone
  | NetworkHost
  | NetworkDefault
  deriving (Show, Eq, Ord)

data RunFlags
  = RunFlags
      { mount :: !(Set RunMount),
        security :: !(Maybe RunSecurity),
        network :: !(Maybe RunNetwork)
      }
  deriving (Show, Eq, Ord)

instance Default RunFlags where
  def = RunFlags mempty Nothing Nothing

data RunArgs args = RunArgs (Arguments args) RunFlags
  deriving (Show, Eq, Ord, Functor)

instance IsString (RunArgs Text) where
  fromString s =
    RunArgs
      (ArgumentsText . Text.pack $ s)
      RunFlags
        { mount = mempty,
          security = Nothing,
          network = Nothing
        }

newtype EscapeChar
  = EscapeChar
      { escape :: Char
      }
  deriving (Show, Eq, Ord)

instance IsChar EscapeChar where
  fromChar c =
    EscapeChar {escape = c}
  toChar e = escape e

newtype SyntaxImage
  = SyntaxImage
      { syntax :: Image
      }
  deriving (Show, Eq, Ord)

data PragmaDirective
  = Escape !EscapeChar
  | Syntax !SyntaxImage
  deriving (Show, Eq, Ord)

-- | All commands available in Dockerfiles
data Instruction args
  = From !BaseImage
  | Add !AddArgs !AddFlags
  | User !Text
  | Label !Pairs
  | Stopsignal !Text
  | Copy !CopyArgs !CopyFlags
  | Run !(RunArgs args)
  | Cmd !(Arguments args)
  | Shell !(Arguments args)
  | Workdir !Directory
  | Expose !Ports
  | Volume !Text
  | Entrypoint !(Arguments args)
  | Maintainer !Text
  | Env !Pairs
  | Arg
      !Text
      !(Maybe Text)
  | Healthcheck !(Check args)
  | Pragma !PragmaDirective
  | Comment !Text
  | OnBuild !(Instruction args)
  deriving (Eq, Ord, Show, Functor)

type Filename = Text

type Linenumber = Int

-- | 'Instruction' with additional location information required for creating
-- good check messages
data InstructionPos args
  = InstructionPos
      { instruction :: !(Instruction args),
        sourcename :: !Filename,
        lineNumber :: !Linenumber
      }
  deriving (Eq, Ord, Show, Functor)

defaultEsc :: Char
defaultEsc = '\\'