{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.Docker.EDSL where

import Control.Monad.Free
import Control.Monad.Free.TH
import Control.Monad.Trans.Free (FreeT, iterTM)
import Control.Monad.Writer
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.Default.Class (def)
import Data.List.NonEmpty (NonEmpty)
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as L
import qualified Data.Text.Lazy.Encoding as E
import Language.Docker.EDSL.Types
import qualified Language.Docker.PrettyPrint as PrettyPrint
import qualified Language.Docker.Syntax as Syntax

-- | The type of 'Identity' based EDSL blocks
type EDockerfileM = Free EInstruction

-- | The type of free monad EDSL blocks
type EDockerfileTM = FreeT EInstruction

type EInstructionM = Free EInstruction

type EInstructionTM = FreeT EInstruction

makeFree ''EInstruction

runDockerWriter :: (MonadWriter [Syntax.Instruction Text] m) => EDockerfileM a -> m a
runDockerWriter :: EDockerfileM a -> m a
runDockerWriter = (EInstruction (m a) -> m a) -> EDockerfileM a -> m a
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
(f (m a) -> m a) -> Free f a -> m a
iterM EInstruction (m a) -> m a
forall (m :: * -> *) b.
MonadWriter [Instruction Text] m =>
EInstruction (m b) -> m b
runD

runDockerWriterIO ::
  (Monad m, MonadTrans t, MonadWriter [Syntax.Instruction Text] (t m)) =>
  EDockerfileTM m a ->
  t m a
runDockerWriterIO :: EDockerfileTM m a -> t m a
runDockerWriterIO = (EInstruction (t m a) -> t m a) -> EDockerfileTM m a -> t m a
forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Functor f, Monad m, MonadTrans t, Monad (t m)) =>
(f (t m a) -> t m a) -> FreeT f m a -> t m a
iterTM EInstruction (t m a) -> t m a
forall (m :: * -> *) b.
MonadWriter [Instruction Text] m =>
EInstruction (m b) -> m b
runD

runDef :: MonadWriter [t] m => (t1 -> t) -> t1 -> m b -> m b
runDef :: (t1 -> t) -> t1 -> m b -> m b
runDef t1 -> t
f t1
a m b
n = [t] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [t1 -> t
f t1
a] m () -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m b
n

runDef2 :: MonadWriter [t] m => (t1 -> t2 -> t) -> t1 -> t2 -> m b -> m b
runDef2 :: (t1 -> t2 -> t) -> t1 -> t2 -> m b -> m b
runDef2 t1 -> t2 -> t
f t1
a t2
b m b
n = [t] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [t1 -> t2 -> t
f t1
a t2
b] m () -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m b
n

runD :: MonadWriter [Syntax.Instruction Text] m => EInstruction (m b) -> m b
runD :: EInstruction (m b) -> m b
runD (From (EBaseImage Image
name Maybe Tag
t Maybe Digest
d Maybe ImageAlias
a Maybe Text
p) m b
n) = (BaseImage -> Instruction Text) -> BaseImage -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef BaseImage -> Instruction Text
forall args. BaseImage -> Instruction args
Syntax.From (Image
-> Maybe Tag
-> Maybe Digest
-> Maybe ImageAlias
-> Maybe Text
-> BaseImage
Syntax.BaseImage Image
name Maybe Tag
t Maybe Digest
d Maybe ImageAlias
a Maybe Text
p) m b
n
runD (CmdArgs Arguments Text
as m b
n) = (Arguments Text -> Instruction Text)
-> Arguments Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Arguments Text -> Instruction Text
forall args. Arguments args -> Instruction args
Syntax.Cmd Arguments Text
as m b
n
runD (Shell Arguments Text
as m b
n) = (Arguments Text -> Instruction Text)
-> Arguments Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Arguments Text -> Instruction Text
forall args. Arguments args -> Instruction args
Syntax.Shell Arguments Text
as m b
n
runD (AddArgs NonEmpty SourcePath
s TargetPath
d Chown
co Chmod
cm m b
n) = (AddArgs -> Instruction Text) -> AddArgs -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef AddArgs -> Instruction Text
forall args. AddArgs -> Instruction args
Syntax.Add (NonEmpty SourcePath -> TargetPath -> Chown -> Chmod -> AddArgs
Syntax.AddArgs NonEmpty SourcePath
s TargetPath
d Chown
co Chmod
cm) m b
n
runD (User Text
u m b
n) = (Text -> Instruction Text) -> Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Text -> Instruction Text
forall args. Text -> Instruction args
Syntax.User Text
u m b
n
runD (Label Pairs
ps m b
n) = (Pairs -> Instruction Text) -> Pairs -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Pairs -> Instruction Text
forall args. Pairs -> Instruction args
Syntax.Label Pairs
ps m b
n
runD (StopSignal Text
s m b
n) = (Text -> Instruction Text) -> Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Text -> Instruction Text
forall args. Text -> Instruction args
Syntax.Stopsignal Text
s m b
n
runD (CopyArgs NonEmpty SourcePath
s TargetPath
d Chown
co Chmod
cm CopySource
f m b
n) = (CopyArgs -> Instruction Text) -> CopyArgs -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef CopyArgs -> Instruction Text
forall args. CopyArgs -> Instruction args
Syntax.Copy (NonEmpty SourcePath
-> TargetPath -> Chown -> Chmod -> CopySource -> CopyArgs
Syntax.CopyArgs NonEmpty SourcePath
s TargetPath
d Chown
co Chmod
cm CopySource
f) m b
n
runD (RunArgs Arguments Text
as RunFlags
fs m b
n) = (RunArgs Text -> Instruction Text) -> RunArgs Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef RunArgs Text -> Instruction Text
forall args. RunArgs args -> Instruction args
Syntax.Run (Arguments Text -> RunFlags -> RunArgs Text
forall args. Arguments args -> RunFlags -> RunArgs args
Syntax.RunArgs Arguments Text
as RunFlags
fs) m b
n
runD (Workdir Text
d m b
n) = (Text -> Instruction Text) -> Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Text -> Instruction Text
forall args. Text -> Instruction args
Syntax.Workdir Text
d m b
n
runD (Expose Ports
ps m b
n) = (Ports -> Instruction Text) -> Ports -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Ports -> Instruction Text
forall args. Ports -> Instruction args
Syntax.Expose Ports
ps m b
n
runD (Volume Text
v m b
n) = (Text -> Instruction Text) -> Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Text -> Instruction Text
forall args. Text -> Instruction args
Syntax.Volume Text
v m b
n
runD (EntrypointArgs Arguments Text
e m b
n) = (Arguments Text -> Instruction Text)
-> Arguments Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Arguments Text -> Instruction Text
forall args. Arguments args -> Instruction args
Syntax.Entrypoint Arguments Text
e m b
n
runD (Maintainer Text
m m b
n) = (Text -> Instruction Text) -> Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Text -> Instruction Text
forall args. Text -> Instruction args
Syntax.Maintainer Text
m m b
n
runD (Env Pairs
ps m b
n) = (Pairs -> Instruction Text) -> Pairs -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Pairs -> Instruction Text
forall args. Pairs -> Instruction args
Syntax.Env Pairs
ps m b
n
runD (Arg Text
k Maybe Text
v m b
n) = (Text -> Maybe Text -> Instruction Text)
-> Text -> Maybe Text -> m b -> m b
forall t (m :: * -> *) t1 t2 b.
MonadWriter [t] m =>
(t1 -> t2 -> t) -> t1 -> t2 -> m b -> m b
runDef2 Text -> Maybe Text -> Instruction Text
forall args. Text -> Maybe Text -> Instruction args
Syntax.Arg Text
k Maybe Text
v m b
n
runD (Comment Text
c m b
n) = (Text -> Instruction Text) -> Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Text -> Instruction Text
forall args. Text -> Instruction args
Syntax.Comment Text
c m b
n
runD (Healthcheck Check Text
c m b
n) = (Check Text -> Instruction Text) -> Check Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Check Text -> Instruction Text
forall args. Check args -> Instruction args
Syntax.Healthcheck Check Text
c m b
n
runD (OnBuildRaw Instruction Text
i m b
n) = (Instruction Text -> Instruction Text)
-> Instruction Text -> m b -> m b
forall t (m :: * -> *) t1 b.
MonadWriter [t] m =>
(t1 -> t) -> t1 -> m b -> m b
runDef Instruction Text -> Instruction Text
forall args. Instruction args -> Instruction args
Syntax.OnBuild Instruction Text
i m b
n
runD (Embed [InstructionPos Text]
is m b
n) = do
  [Instruction Text] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ((InstructionPos Text -> Instruction Text)
-> [InstructionPos Text] -> [Instruction Text]
forall a b. (a -> b) -> [a] -> [b]
map InstructionPos Text -> Instruction Text
forall args. InstructionPos args -> Instruction args
Syntax.instruction [InstructionPos Text]
is)
  m b
n

instructionPos :: Syntax.Instruction args -> Syntax.InstructionPos args
instructionPos :: Instruction args -> InstructionPos args
instructionPos Instruction args
i = Instruction args -> Text -> Linenumber -> InstructionPos args
forall args.
Instruction args -> Text -> Linenumber -> InstructionPos args
Syntax.InstructionPos Instruction args
i Text
"" Linenumber
0

-- | Runs the Dockerfile EDSL and returns a 'Dockerfile' you can pretty print
-- or manipulate
toDockerfile :: EDockerfileM a -> Syntax.Dockerfile
toDockerfile :: EDockerfileM a -> [InstructionPos Text]
toDockerfile EDockerfileM a
e =
  let (a
_, [Instruction Text]
w) = Writer [Instruction Text] a -> (a, [Instruction Text])
forall w a. Writer w a -> (a, w)
runWriter (EDockerfileM a -> Writer [Instruction Text] a
forall (m :: * -> *) a.
MonadWriter [Instruction Text] m =>
EDockerfileM a -> m a
runDockerWriter EDockerfileM a
e)
   in (Instruction Text -> InstructionPos Text)
-> [Instruction Text] -> [InstructionPos Text]
forall a b. (a -> b) -> [a] -> [b]
map Instruction Text -> InstructionPos Text
forall args. Instruction args -> InstructionPos args
instructionPos [Instruction Text]
w

-- | runs the Dockerfile EDSL and returns a 'Data.Text.Lazy' using
-- 'Language.Docker.PrettyPrint'
--
-- @
-- import Language.Docker
--
-- main :: IO ()
-- main = print $ toDockerfileText $ do
--     from (tagged "fpco/stack-build" "lts-6.9")
--     add ["."] "/app/language-docker"
--     workdir "/app/language-docker"
--     run "stack build --test --only-dependencies"
--     cmd "stack test"
-- @
toDockerfileText :: EDockerfileM a -> L.Text
toDockerfileText :: EDockerfileM a -> Text
toDockerfileText = [InstructionPos Text] -> Text
PrettyPrint.prettyPrint ([InstructionPos Text] -> Text)
-> (EDockerfileM a -> [InstructionPos Text])
-> EDockerfileM a
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EDockerfileM a -> [InstructionPos Text]
forall a. EDockerfileM a -> [InstructionPos Text]
toDockerfile

-- | Writes the dockerfile to the given file path after pretty-printing it
--
-- @
-- import Language.Docker
--
-- main :: IO ()
-- main = writeDockerFile "build.Dockerfile" $ toDockerfile $ do
--     from (tagged "fpco/stack-build" "lts-6.9")
--     add ["."] "/app/language-docker"
--     workdir "/app/language-docker"
--     run "stack build --test --only-dependencies"
--     cmd "stack test"
-- @
writeDockerFile :: Text -> Syntax.Dockerfile -> IO ()
writeDockerFile :: Text -> [InstructionPos Text] -> IO ()
writeDockerFile Text
filename =
  FilePath -> ByteString -> IO ()
BL.writeFile (Text -> FilePath
Text.unpack Text
filename) (ByteString -> IO ())
-> ([InstructionPos Text] -> ByteString)
-> [InstructionPos Text]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
E.encodeUtf8 (Text -> ByteString)
-> ([InstructionPos Text] -> Text)
-> [InstructionPos Text]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstructionPos Text] -> Text
PrettyPrint.prettyPrint

-- | Prints the dockerfile to stdout. Mainly used for debugging purposes
--
-- @
-- import Language.Docker
--
-- main :: IO ()
-- main = putDockerfileStr $ do
--     from (tagged "fpco/stack-build" "lts-6.9")
--     add ["."] "/app/language-docker"
--     workdir "/app/language-docker"
--     run "stack build --test --only-dependencies"
--     cmd "stack test"
-- @
putDockerfileStr :: EDockerfileM a -> IO ()
putDockerfileStr :: EDockerfileM a -> IO ()
putDockerfileStr = ByteString -> IO ()
B8.putStrLn (ByteString -> IO ())
-> (EDockerfileM a -> ByteString) -> EDockerfileM a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
E.encodeUtf8 (Text -> ByteString)
-> (EDockerfileM a -> Text) -> EDockerfileM a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstructionPos Text] -> Text
PrettyPrint.prettyPrint ([InstructionPos Text] -> Text)
-> (EDockerfileM a -> [InstructionPos Text])
-> EDockerfileM a
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EDockerfileM a -> [InstructionPos Text]
forall a. EDockerfileM a -> [InstructionPos Text]
toDockerfile

-- | Use a docker image in a FROM instruction without a tag
--
-- The following two examples are equivalent
--
-- @
-- from $ untagged "fpco/stack-build"
-- @
--
-- Is equivalent to, when having OverloadedStrings:
--
-- @
-- from "fpco/stack-build"
-- @
untagged :: Text -> EBaseImage
untagged :: Text -> EBaseImage
untagged Text
s = Image
-> Maybe Tag
-> Maybe Digest
-> Maybe ImageAlias
-> Maybe Text
-> EBaseImage
EBaseImage (FilePath -> Image
forall a. IsString a => FilePath -> a
fromString (FilePath -> Image) -> (Text -> FilePath) -> Text -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack (Text -> Image) -> Text -> Image
forall a b. (a -> b) -> a -> b
$ Text
s) Maybe Tag
forall a. Maybe a
Nothing Maybe Digest
forall a. Maybe a
Nothing Maybe ImageAlias
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing

-- | Use a specific tag for a docker image. This function is meant
-- to be used as an infix operator.
--
-- @
-- from $ "fpco/stack-build" `tagged` "lts-10.3"
-- @
tagged :: Syntax.Image -> Syntax.Tag -> EBaseImage
tagged :: Image -> Tag -> EBaseImage
tagged Image
imageName Tag
tag = Image
-> Maybe Tag
-> Maybe Digest
-> Maybe ImageAlias
-> Maybe Text
-> EBaseImage
EBaseImage Image
imageName (Tag -> Maybe Tag
forall a. a -> Maybe a
Just Tag
tag) Maybe Digest
forall a. Maybe a
Nothing Maybe ImageAlias
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing

-- | Adds a digest checksum so a FROM instruction
-- This function is meant to be used as an infix operator.
--
-- @
-- from $ "fpco/stack-build" `digested` "sha256:abcdef123"
-- @
digested :: EBaseImage -> Syntax.Digest -> EBaseImage
digested :: EBaseImage -> Digest -> EBaseImage
digested (EBaseImage Image
n Maybe Tag
t Maybe Digest
_ Maybe ImageAlias
a Maybe Text
p) Digest
d = Image
-> Maybe Tag
-> Maybe Digest
-> Maybe ImageAlias
-> Maybe Text
-> EBaseImage
EBaseImage Image
n Maybe Tag
t (Digest -> Maybe Digest
forall a. a -> Maybe a
Just Digest
d) Maybe ImageAlias
a Maybe Text
p

-- | Alias a FROM instruction to be used as a build stage.
-- This function is meant to be used as an infix operator.
--
-- @
-- from $ "fpco/stack-build" `aliased` "builder"
-- @
aliased :: EBaseImage -> Syntax.ImageAlias -> EBaseImage
aliased :: EBaseImage -> ImageAlias -> EBaseImage
aliased (EBaseImage Image
n Maybe Tag
t Maybe Digest
d Maybe ImageAlias
_ Maybe Text
p) ImageAlias
a = Image
-> Maybe Tag
-> Maybe Digest
-> Maybe ImageAlias
-> Maybe Text
-> EBaseImage
EBaseImage Image
n Maybe Tag
t Maybe Digest
d (ImageAlias -> Maybe ImageAlias
forall a. a -> Maybe a
Just ImageAlias
a) Maybe Text
p

-- | Create a RUN instruction with the given arguments.
--
-- @
-- run "apt-get install wget"
-- @
run :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()
run :: Arguments Text -> m ()
run Arguments Text
as = Arguments Text -> RunFlags -> m ()
forall (m :: * -> *).
MonadFree EInstruction m =>
Arguments Text -> RunFlags -> m ()
runArgs Arguments Text
as RunFlags
forall a. Default a => a
def

-- | Create an ENTRYPOINT instruction with the given arguments.
--
-- @
-- entrypoint "/usr/local/bin/program --some-flag"
-- @
entrypoint :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()
entrypoint :: Arguments Text -> m ()
entrypoint = Arguments Text -> m ()
forall (m :: * -> *).
MonadFree EInstruction m =>
Arguments Text -> m ()
entrypointArgs

-- | Create a CMD instruction with the given arguments.
--
-- @
-- cmd "my-program --some-flag"
-- @
cmd :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()
cmd :: Arguments Text -> m ()
cmd = Arguments Text -> m ()
forall (m :: * -> *).
MonadFree EInstruction m =>
Arguments Text -> m ()
cmdArgs

-- | Create a COPY instruction. This function is meant to be
-- used with the compinators 'to', 'fromStage' and 'ownedBy'
--
-- @
-- copy $ ["foo.js", "bar.js"] `to` "."
-- copy $ ["some_file"] `to` "/some/path" `fromStage` "builder"
-- @
copy :: MonadFree EInstruction m => Syntax.CopyArgs -> m ()
copy :: CopyArgs -> m ()
copy (Syntax.CopyArgs NonEmpty SourcePath
sources TargetPath
dest Chown
co Chmod
cm CopySource
src) = NonEmpty SourcePath
-> TargetPath -> Chown -> Chmod -> CopySource -> m ()
forall (m :: * -> *).
MonadFree EInstruction m =>
NonEmpty SourcePath
-> TargetPath -> Chown -> Chmod -> CopySource -> m ()
copyArgs NonEmpty SourcePath
sources TargetPath
dest Chown
co Chmod
cm CopySource
src

-- | Create a COPY instruction from a given build stage.
-- This is a shorthand version of using 'copy' with combinators.
--
-- @
-- copyFromStage "builder" ["foo.js", "bar.js"] "."
-- @
copyFromStage ::
  MonadFree EInstruction m =>
  Syntax.CopySource ->
  NonEmpty Syntax.SourcePath ->
  Syntax.TargetPath ->
  m ()
copyFromStage :: CopySource -> NonEmpty SourcePath -> TargetPath -> m ()
copyFromStage CopySource
stage NonEmpty SourcePath
source TargetPath
dest = CopyArgs -> m ()
forall (m :: * -> *). MonadFree EInstruction m => CopyArgs -> m ()
copy (CopyArgs -> m ()) -> CopyArgs -> m ()
forall a b. (a -> b) -> a -> b
$ NonEmpty SourcePath
-> TargetPath -> Chown -> Chmod -> CopySource -> CopyArgs
Syntax.CopyArgs NonEmpty SourcePath
source TargetPath
dest Chown
Syntax.NoChown Chmod
Syntax.NoChmod CopySource
stage

-- | Create an ADD instruction. This is often used as a shorthand version
-- of copy when no extra options are needed. Currently there is no way to
-- pass extra options to ADD, so you are encouraged to use 'copy' instead.
--
-- @
-- add ["foo.js", "bar.js"] "."
-- @
add :: MonadFree EInstruction m => NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> m ()
add :: NonEmpty SourcePath -> TargetPath -> m ()
add NonEmpty SourcePath
sources TargetPath
dest = NonEmpty SourcePath -> TargetPath -> Chown -> Chmod -> m ()
forall (m :: * -> *).
MonadFree EInstruction m =>
NonEmpty SourcePath -> TargetPath -> Chown -> Chmod -> m ()
addArgs NonEmpty SourcePath
sources TargetPath
dest Chown
Syntax.NoChown Chmod
Syntax.NoChmod

-- | Converts a NonEmpty list of strings to a NonEmpty list of 'Syntax.SourcePath'
--
-- This is a convenience function when you need to pass a non-static list of
-- strings that you build somewhere as an argument for 'copy' or 'add'
--
-- @
-- someFiles <- glob "*.js"
-- copy $ (toSources someFiles) `to` "."
-- @
toSources :: NonEmpty Text -> NonEmpty Syntax.SourcePath
toSources :: NonEmpty Text -> NonEmpty SourcePath
toSources = (Text -> SourcePath) -> NonEmpty Text -> NonEmpty SourcePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> SourcePath
Syntax.SourcePath

-- | Converts a Text into a 'Syntax.TargetPath'
--
-- This is a convenience function when you need to pass a string variable
-- as an argument for 'copy' or 'add'
--
-- @
-- let destination = buildSomePath pwd
-- add ["foo.js"] (toTarget destination)
-- @
toTarget :: Text -> Syntax.TargetPath
toTarget :: Text -> TargetPath
toTarget = Text -> TargetPath
Syntax.TargetPath

-- | Adds the --from= option to a COPY instruction.
--
-- This function is meant to be used as an infix operator:
--
-- @
-- copy $ ["foo.js"] `to` "." `fromStage` "builder"
-- @
fromStage :: Syntax.CopyArgs -> Syntax.CopySource -> Syntax.CopyArgs
fromStage :: CopyArgs -> CopySource -> CopyArgs
fromStage CopyArgs
args CopySource
src = CopyArgs
args {$sel:sourceFlag:CopyArgs :: CopySource
Syntax.sourceFlag = CopySource
src}

-- | Adds the --chown= option to a COPY instruction.
--
-- This function is meant to be used as an infix operator:
--
-- @
-- copy $ ["foo.js"] `to` "." `ownedBy` "www-data:www-data"
-- @
ownedBy :: Syntax.CopyArgs -> Syntax.Chown -> Syntax.CopyArgs
ownedBy :: CopyArgs -> Chown -> CopyArgs
ownedBy CopyArgs
args Chown
owner = CopyArgs
args {$sel:chownFlag:CopyArgs :: Chown
Syntax.chownFlag = Chown
owner}

-- | Usedto join source paths with atarget path as an arguments for 'copy'
--
-- This function is meant to be used as an infix operator:
--
-- @
-- copy $ ["foo.js"] `to` "." `ownedBy`
-- @
to :: NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> Syntax.CopyArgs
to :: NonEmpty SourcePath -> TargetPath -> CopyArgs
to NonEmpty SourcePath
sources TargetPath
dest = NonEmpty SourcePath
-> TargetPath -> Chown -> Chmod -> CopySource -> CopyArgs
Syntax.CopyArgs NonEmpty SourcePath
sources TargetPath
dest Chown
Syntax.NoChown Chmod
Syntax.NoChmod CopySource
Syntax.NoSource

ports :: [Syntax.Port] -> Syntax.Ports
ports :: [Port] -> Ports
ports = [Port] -> Ports
Syntax.Ports

tcpPort :: Int -> Syntax.Port
tcpPort :: Linenumber -> Port
tcpPort = (Linenumber -> Protocol -> Port) -> Protocol -> Linenumber -> Port
forall a b c. (a -> b -> c) -> b -> a -> c
flip Linenumber -> Protocol -> Port
Syntax.Port Protocol
Syntax.TCP

udpPort :: Int -> Syntax.Port
udpPort :: Linenumber -> Port
udpPort = (Linenumber -> Protocol -> Port) -> Protocol -> Linenumber -> Port
forall a b c. (a -> b -> c) -> b -> a -> c
flip Linenumber -> Protocol -> Port
Syntax.Port Protocol
Syntax.UDP

variablePort :: Text -> Syntax.Port
variablePort :: Text -> Port
variablePort Text
varName = Text -> Port
Syntax.PortStr (Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
varName)

portRange :: Int -> Int -> Syntax.Port
portRange :: Linenumber -> Linenumber -> Port
portRange Linenumber
a Linenumber
b = Linenumber -> Linenumber -> Protocol -> Port
Syntax.PortRange Linenumber
a Linenumber
b Protocol
Syntax.TCP

udpPortRange :: Int -> Int -> Syntax.Port
udpPortRange :: Linenumber -> Linenumber -> Port
udpPortRange Linenumber
a Linenumber
b = Linenumber -> Linenumber -> Protocol -> Port
Syntax.PortRange Linenumber
a Linenumber
b Protocol
Syntax.UDP

check :: Syntax.Arguments args -> Syntax.Check args
check :: Arguments args -> Check args
check Arguments args
command =
  CheckArgs args -> Check args
forall args. CheckArgs args -> Check args
Syntax.Check
    CheckArgs :: forall args.
Arguments args
-> Maybe Duration
-> Maybe Duration
-> Maybe Duration
-> Maybe Retries
-> CheckArgs args
Syntax.CheckArgs
      { $sel:checkCommand:CheckArgs :: Arguments args
Syntax.checkCommand = Arguments args
command,
        $sel:interval:CheckArgs :: Maybe Duration
Syntax.interval = Maybe Duration
forall a. Maybe a
Nothing,
        $sel:timeout:CheckArgs :: Maybe Duration
Syntax.timeout = Maybe Duration
forall a. Maybe a
Nothing,
        $sel:startPeriod:CheckArgs :: Maybe Duration
Syntax.startPeriod = Maybe Duration
forall a. Maybe a
Nothing,
        $sel:retries:CheckArgs :: Maybe Retries
Syntax.retries = Maybe Retries
forall a. Maybe a
Nothing
      }

interval :: Syntax.Check args -> Integer -> Syntax.Check args
interval :: Check args -> Integer -> Check args
interval Check args
ch Integer
secs =
  case Check args
ch of
    Check args
Syntax.NoCheck -> Check args
forall args. Check args
Syntax.NoCheck
    Syntax.Check CheckArgs args
chArgs -> CheckArgs args -> Check args
forall args. CheckArgs args -> Check args
Syntax.Check CheckArgs args
chArgs {$sel:interval:CheckArgs :: Maybe Duration
Syntax.interval = Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ Integer -> Duration
forall a. Num a => Integer -> a
fromInteger Integer
secs}

timeout :: Syntax.Check args -> Integer -> Syntax.Check args
timeout :: Check args -> Integer -> Check args
timeout Check args
ch Integer
secs =
  case Check args
ch of
    Check args
Syntax.NoCheck -> Check args
forall args. Check args
Syntax.NoCheck
    Syntax.Check CheckArgs args
chArgs -> CheckArgs args -> Check args
forall args. CheckArgs args -> Check args
Syntax.Check CheckArgs args
chArgs {$sel:timeout:CheckArgs :: Maybe Duration
Syntax.timeout = Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ Integer -> Duration
forall a. Num a => Integer -> a
fromInteger Integer
secs}

startPeriod :: Syntax.Check args -> Integer -> Syntax.Check args
startPeriod :: Check args -> Integer -> Check args
startPeriod Check args
ch Integer
secs =
  case Check args
ch of
    Check args
Syntax.NoCheck -> Check args
forall args. Check args
Syntax.NoCheck
    Syntax.Check CheckArgs args
chArgs -> CheckArgs args -> Check args
forall args. CheckArgs args -> Check args
Syntax.Check CheckArgs args
chArgs {$sel:startPeriod:CheckArgs :: Maybe Duration
Syntax.startPeriod = Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ Integer -> Duration
forall a. Num a => Integer -> a
fromInteger Integer
secs}

retries :: Syntax.Check args -> Integer -> Syntax.Check args
retries :: Check args -> Integer -> Check args
retries Check args
ch Integer
tries =
  case Check args
ch of
    Check args
Syntax.NoCheck -> Check args
forall args. Check args
Syntax.NoCheck
    Syntax.Check CheckArgs args
chArgs -> CheckArgs args -> Check args
forall args. CheckArgs args -> Check args
Syntax.Check CheckArgs args
chArgs {$sel:retries:CheckArgs :: Maybe Retries
Syntax.retries = Retries -> Maybe Retries
forall a. a -> Maybe a
Just (Retries -> Maybe Retries) -> Retries -> Maybe Retries
forall a b. (a -> b) -> a -> b
$ Integer -> Retries
forall a. Num a => Integer -> a
fromInteger Integer
tries}

noCheck :: Syntax.Check args
noCheck :: Check args
noCheck = Check args
forall args. Check args
Syntax.NoCheck

-- | ONBUILD Dockerfile instruction
--
-- Each nested instruction gets emitted as a separate @ONBUILD@ block
--
-- @
-- 'toDockerfile' $ do
--     from "node"
--     run "apt-get update"
--     onBuild $ do
--         run "echo more-stuff"
--         run "echo here"
-- @
onBuild :: MonadFree EInstruction m => EDockerfileM a -> m ()
onBuild :: EDockerfileM a -> m ()
onBuild EDockerfileM a
b = (InstructionPos Text -> m ()) -> [InstructionPos Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Instruction Text -> m ()
forall (m :: * -> *).
MonadFree EInstruction m =>
Instruction Text -> m ()
onBuildRaw (Instruction Text -> m ())
-> (InstructionPos Text -> Instruction Text)
-> InstructionPos Text
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstructionPos Text -> Instruction Text
forall args. InstructionPos args -> Instruction args
Syntax.instruction) (EDockerfileM a -> [InstructionPos Text]
forall a. EDockerfileM a -> [InstructionPos Text]
toDockerfile EDockerfileM a
b)

-- | A version of 'toDockerfile' which allows IO actions
toDockerfileIO :: MonadIO m => EDockerfileTM m t -> m Syntax.Dockerfile
toDockerfileIO :: EDockerfileTM m t -> m [InstructionPos Text]
toDockerfileIO EDockerfileTM m t
e = ((t, [InstructionPos Text]) -> [InstructionPos Text])
-> m (t, [InstructionPos Text]) -> m [InstructionPos Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t, [InstructionPos Text]) -> [InstructionPos Text]
forall a b. (a, b) -> b
snd (EDockerfileTM m t -> m (t, [InstructionPos Text])
forall (m :: * -> *) t.
MonadIO m =>
EDockerfileTM m t -> m (t, [InstructionPos Text])
runDockerfileIO EDockerfileTM m t
e)

-- | A version of 'toDockerfileText' which allows IO actions
toDockerfileTextIO :: MonadIO m => EDockerfileTM m t -> m L.Text
toDockerfileTextIO :: EDockerfileTM m t -> m Text
toDockerfileTextIO EDockerfileTM m t
e = ((t, Text) -> Text) -> m (t, Text) -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t, Text) -> Text
forall a b. (a, b) -> b
snd (EDockerfileTM m t -> m (t, Text)
forall (m :: * -> *) t.
MonadIO m =>
EDockerfileTM m t -> m (t, Text)
runDockerfileTextIO EDockerfileTM m t
e)

-- | Just runs the EDSL's writer monad
runDockerfileIO :: MonadIO m => EDockerfileTM m t -> m (t, Syntax.Dockerfile)
runDockerfileIO :: EDockerfileTM m t -> m (t, [InstructionPos Text])
runDockerfileIO EDockerfileTM m t
e = do
  (t
r, [Instruction Text]
w) <- WriterT [Instruction Text] m t -> m (t, [Instruction Text])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (EDockerfileTM m t -> WriterT [Instruction Text] m t
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, MonadTrans t, MonadWriter [Instruction Text] (t m)) =>
EDockerfileTM m a -> t m a
runDockerWriterIO EDockerfileTM m t
e)
  (t, [InstructionPos Text]) -> m (t, [InstructionPos Text])
forall (m :: * -> *) a. Monad m => a -> m a
return (t
r, (Instruction Text -> InstructionPos Text)
-> [Instruction Text] -> [InstructionPos Text]
forall a b. (a -> b) -> [a] -> [b]
map Instruction Text -> InstructionPos Text
forall args. Instruction args -> InstructionPos args
instructionPos [Instruction Text]
w)

-- | Runs the EDSL's writer monad and pretty-prints the result
runDockerfileTextIO :: MonadIO m => EDockerfileTM m t -> m (t, L.Text)
runDockerfileTextIO :: EDockerfileTM m t -> m (t, Text)
runDockerfileTextIO EDockerfileTM m t
e = do
  (t
r, [InstructionPos Text]
w) <- EDockerfileTM m t -> m (t, [InstructionPos Text])
forall (m :: * -> *) t.
MonadIO m =>
EDockerfileTM m t -> m (t, [InstructionPos Text])
runDockerfileIO EDockerfileTM m t
e
  (t, Text) -> m (t, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (t
r, [InstructionPos Text] -> Text
PrettyPrint.prettyPrint [InstructionPos Text]
w)