{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies,
DuplicateRecordFields, FlexibleInstances, DeriveFunctor #-}
module Language.Docker.Syntax where
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 case parts of
reg:rest ->
Image
(Just (Registry (Text.pack reg)))
(Text.pack . intercalate "/" $ rest)
_ -> 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)
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
newtype ImageAlias = ImageAlias
{ unImageAlias :: Text
} deriving (Show, Eq, Ord, IsString)
data BaseImage
= UntaggedImage !Image
!(Maybe ImageAlias)
| TaggedImage !Image
!Tag
!(Maybe ImageAlias)
| DigestedImage !Image
!Text
!(Maybe ImageAlias)
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 Instruction args
= From !BaseImage
| Add !AddArgs
| User !Text
| Label !Pairs
| Stopsignal !Text
| Copy !CopyArgs
| Run !(Arguments 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)