{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# 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.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 qualified Language.Docker.PrettyPrint as PrettyPrint
import qualified Language.Docker.Syntax as Syntax
import Language.Docker.EDSL.Types
type EDockerfileM = Free EInstruction
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 = iterM runD
runDockerWriterIO ::
(Monad m, MonadTrans t, MonadWriter [Syntax.Instruction Text] (t m))
=> EDockerfileTM m a
-> t m a
runDockerWriterIO = iterTM runD
runDef :: MonadWriter [t] m => (t1 -> t) -> t1 -> m b -> m b
runDef f a n = tell [f a] >> n
runDef2 :: MonadWriter [t] m => (t1 -> t2 -> t) -> t1 -> t2 -> m b -> m b
runDef2 f a b n = tell [f a b] >> n
runD :: MonadWriter [Syntax.Instruction Text] m => EInstruction (m b) -> m b
runD (From bi n) =
case bi of
EUntaggedImage bi' alias -> runDef Syntax.From (Syntax.UntaggedImage bi' alias) n
ETaggedImage bi' tg alias -> runDef Syntax.From (Syntax.TaggedImage bi' tg alias) n
EDigestedImage bi' d alias -> runDef Syntax.From (Syntax.DigestedImage bi' d alias) n
runD (CmdArgs as n) = runDef Syntax.Cmd as n
runD (Shell as n) = runDef Syntax.Shell as n
runD (AddArgs s d c n) = runDef Syntax.Add (Syntax.AddArgs s d c) n
runD (User u n) = runDef Syntax.User u n
runD (Label ps n) = runDef Syntax.Label ps n
runD (StopSignal s n) = runDef Syntax.Stopsignal s n
runD (CopyArgs s d c f n) = runDef Syntax.Copy (Syntax.CopyArgs s d c f) n
runD (RunArgs as n) = runDef Syntax.Run as n
runD (Workdir d n) = runDef Syntax.Workdir d n
runD (Expose ps n) = runDef Syntax.Expose ps n
runD (Volume v n) = runDef Syntax.Volume v n
runD (EntrypointArgs e n) = runDef Syntax.Entrypoint e n
runD (Maintainer m n) = runDef Syntax.Maintainer m n
runD (Env ps n) = runDef Syntax.Env ps n
runD (Arg k v n) = runDef2 Syntax.Arg k v n
runD (Comment c n) = runDef Syntax.Comment c n
runD (Healthcheck c n) = runDef Syntax.Healthcheck c n
runD (OnBuildRaw i n) = runDef Syntax.OnBuild i n
runD (Embed is n) = do
tell (map Syntax.instruction is)
n
instructionPos :: Syntax.Instruction args -> Syntax.InstructionPos args
instructionPos i = Syntax.InstructionPos i "" 0
toDockerfile :: EDockerfileM a -> Syntax.Dockerfile
toDockerfile e =
let (_, w) = runWriter (runDockerWriter e)
in map instructionPos w
toDockerfileText :: EDockerfileM a -> L.Text
toDockerfileText = PrettyPrint.prettyPrint . toDockerfile
writeDockerFile :: Text -> Syntax.Dockerfile -> IO ()
writeDockerFile filename =
BL.writeFile (Text.unpack filename) . E.encodeUtf8 . PrettyPrint.prettyPrint
putDockerfileStr :: EDockerfileM a -> IO ()
putDockerfileStr = B8.putStrLn . E.encodeUtf8 . PrettyPrint.prettyPrint . toDockerfile
untagged :: Text -> EBaseImage
untagged = flip EUntaggedImage Nothing . fromString . Text.unpack
tagged :: Syntax.Image -> Syntax.Tag -> EBaseImage
tagged imageName tag = ETaggedImage imageName tag Nothing
digested :: Syntax.Image -> Text -> EBaseImage
digested imageName hash = EDigestedImage imageName hash Nothing
aliased :: EBaseImage -> Text -> EBaseImage
aliased image alias =
case image of
EUntaggedImage n _ -> EUntaggedImage n (Just $ Syntax.ImageAlias alias)
ETaggedImage n t _ -> ETaggedImage n t (Just $ Syntax.ImageAlias alias)
EDigestedImage n h _ -> EDigestedImage n h (Just $ Syntax.ImageAlias alias)
run :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()
run = runArgs
entrypoint :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()
entrypoint = entrypointArgs
cmd :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()
cmd = cmdArgs
copy :: MonadFree EInstruction m => Syntax.CopyArgs -> m ()
copy (Syntax.CopyArgs sources dest ch src) = copyArgs sources dest ch src
copyFromStage ::
MonadFree EInstruction m
=> Syntax.CopySource
-> NonEmpty Syntax.SourcePath
-> Syntax.TargetPath
-> m ()
copyFromStage stage source dest = copy $ Syntax.CopyArgs source dest Syntax.NoChown stage
add :: MonadFree EInstruction m => NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> m ()
add sources dest = addArgs sources dest Syntax.NoChown
toSources :: NonEmpty Text -> NonEmpty Syntax.SourcePath
toSources = fmap Syntax.SourcePath
toTarget :: Text -> Syntax.TargetPath
toTarget = Syntax.TargetPath
fromStage :: Syntax.CopyArgs -> Syntax.CopySource -> Syntax.CopyArgs
fromStage args src = args {Syntax.sourceFlag = src}
ownedBy :: Syntax.CopyArgs -> Syntax.Chown -> Syntax.CopyArgs
ownedBy args owner = args {Syntax.chownFlag = owner}
to :: NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> Syntax.CopyArgs
to sources dest = Syntax.CopyArgs sources dest Syntax.NoChown Syntax.NoSource
ports :: [Syntax.Port] -> Syntax.Ports
ports = Syntax.Ports
tcpPort :: Int -> Syntax.Port
tcpPort = flip Syntax.Port Syntax.TCP
udpPort :: Int -> Syntax.Port
udpPort = flip Syntax.Port Syntax.UDP
variablePort :: Text -> Syntax.Port
variablePort varName = Syntax.PortStr ("$" <> varName)
portRange :: Int -> Int -> Syntax.Port
portRange a b = Syntax.PortRange a b Syntax.TCP
udpPortRange :: Int -> Int -> Syntax.Port
udpPortRange a b = Syntax.PortRange a b Syntax.UDP
check :: Syntax.Arguments args -> Syntax.Check args
check command =
Syntax.Check
Syntax.CheckArgs
{ Syntax.checkCommand = command
, Syntax.interval = Nothing
, Syntax.timeout = Nothing
, Syntax.startPeriod = Nothing
, Syntax.retries = Nothing
}
interval :: Syntax.Check args -> Integer -> Syntax.Check args
interval ch secs =
case ch of
Syntax.NoCheck -> Syntax.NoCheck
Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.interval = Just $ fromInteger secs}
timeout :: Syntax.Check args -> Integer -> Syntax.Check args
timeout ch secs =
case ch of
Syntax.NoCheck -> Syntax.NoCheck
Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.timeout = Just $ fromInteger secs}
startPeriod :: Syntax.Check args -> Integer -> Syntax.Check args
startPeriod ch secs =
case ch of
Syntax.NoCheck -> Syntax.NoCheck
Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.startPeriod = Just $ fromInteger secs}
retries :: Syntax.Check args -> Integer -> Syntax.Check args
retries ch tries =
case ch of
Syntax.NoCheck -> Syntax.NoCheck
Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.retries = Just $ fromInteger tries}
noCheck :: Syntax.Check args
noCheck = Syntax.NoCheck
onBuild :: MonadFree EInstruction m => EDockerfileM a -> m ()
onBuild b = mapM_ (onBuildRaw . Syntax.instruction) (toDockerfile b)
toDockerfileIO :: MonadIO m => EDockerfileTM m t -> m Syntax.Dockerfile
toDockerfileIO e = fmap snd (runDockerfileIO e)
toDockerfileTextIO :: MonadIO m => EDockerfileTM m t -> m L.Text
toDockerfileTextIO e = fmap snd (runDockerfileTextIO e)
runDockerfileIO :: MonadIO m => EDockerfileTM m t -> m (t, Syntax.Dockerfile)
runDockerfileIO e = do
(r, w) <- runWriterT (runDockerWriterIO e)
return (r, map instructionPos w)
runDockerfileTextIO :: MonadIO m => EDockerfileTM m t -> m (t, L.Text)
runDockerfileTextIO e = do
(r, w) <- runDockerfileIO e
return (r, PrettyPrint.prettyPrint w)