{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Language.Docker.Syntax 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 qualified Data.Text as Text
import Data.Time.Clock (DiffTime)
import GHC.Exts (IsList (..))
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 Protocol
= TCP
| UDP
deriving (Show, Eq, Ord)
data Port
= Port
!Int
!Protocol
| PortStr !Text
| PortRange
!Int
!Int
!Protocol
deriving (Show, Eq, Ord)
newtype Ports
= Ports
{ unPorts :: [Port]
}
deriving (Show, Eq, Ord)
instance IsList Ports where
type Item Ports = Port
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 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 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)
newtype Retries
= Retries
{ times :: Int
}
deriving (Show, Eq, Ord, Num)
data CopyArgs
= CopyArgs
{ sourcePaths :: NonEmpty SourcePath,
targetPath :: !TargetPath,
chownFlag :: !Chown,
sourceFlag :: !CopySource
}
deriving (Show, Eq, Ord)
data AddArgs
= AddArgs
{ sourcePaths :: NonEmpty SourcePath,
targetPath :: !TargetPath,
chownFlag :: !Chown
}
deriving (Show, Eq, Ord)
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 :: !CacheSharing,
cCacheId :: !(Maybe Text),
cReadOnly :: !(Maybe Bool),
cFromImage :: !(Maybe Text),
cSource :: !(Maybe SourcePath),
cMode :: !(Maybe Text),
cUid :: !(Maybe Integer),
cGid :: !(Maybe Integer)
}
deriving (Show, Eq, Ord)
instance Default CacheOpts where
def = CacheOpts "" Shared 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 Integer),
sGid :: !(Maybe Integer)
}
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 :: !(Maybe RunMount),
security :: !(Maybe RunSecurity),
network :: !(Maybe RunNetwork)
}
deriving (Show, Eq, Ord)
instance Default RunFlags where
def = RunFlags Nothing 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
{ security = Nothing,
network = Nothing,
mount = Nothing
}
data Instruction args
= From !BaseImage
| Add !AddArgs
| User !Text
| Label !Pairs
| Stopsignal !Text
| Copy !CopyArgs
| 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)
| Comment !Text
| OnBuild !(Instruction args)
deriving (Eq, Ord, Show, Functor)
type Filename = Text
type Linenumber = Int
data InstructionPos args
= InstructionPos
{ instruction :: !(Instruction args),
sourcename :: !Filename,
lineNumber :: !Linenumber
}
deriving (Eq, Ord, Show, Functor)