{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} module Language.Dockerfile.EDSL where -- import Control.Exception -- import Data.List (isInfixOf) import Control.Monad.Free import Control.Monad.Free.TH import Control.Monad.Identity (Identity) import Control.Monad.Trans.Free (FreeT, iterTM, runFreeT) import Control.Monad.Writer import Data.ByteString (ByteString) import qualified Language.Dockerfile.PrettyPrint as PrettyPrint import qualified Language.Dockerfile.Syntax as Syntax import Language.Dockerfile.EDSL.Types type EInstructionM = Free EInstruction type EInstructionTM = FreeT EInstruction makeFree ''EInstruction runDockerWriter :: (MonadWriter [Syntax.Instruction] m) => EInstructionM a -> m a runDockerWriter = iterM runD runDockerWriterIO :: ( Monad m , MonadTrans t , Monad (t m) , MonadWriter [Syntax.Instruction] (t m) , MonadIO (t m) ) => EInstructionTM 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] m => EInstruction (m b) -> m b runD (From bi n) = case bi of EUntaggedImage bi' -> runDef Syntax.From (Syntax.UntaggedImage bi') n ETaggedImage bi' tg -> runDef Syntax.From (Syntax.TaggedImage bi' tg) n EDigestedImage bi' d -> runDef Syntax.From (Syntax.DigestedImage bi' d) n runD (CmdArgs as n) = runDef Syntax.Cmd as n runD (Add s d n) = runDef2 Syntax.Add s d 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 (Copy s d n) = runDef2 Syntax.Copy s d 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 s n) = runDef Syntax.Arg s n runD (Comment c n) = runDef Syntax.Comment 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 -> Syntax.InstructionPos instructionPos i = Syntax.InstructionPos i "" 0 -- | Runs the Dockerfile EDSL and returns a 'Dockerfile' you can pretty print -- or manipulate toDockerfile :: EInstructionM a -> Syntax.Dockerfile toDockerfile e = let (_, w) = runWriter (runDockerWriter e) in map instructionPos w -- | runs the Dockerfile EDSL and returns a 'String' using -- 'Language.Dockerfile.PrettyPrint' -- -- @ -- import Language.Dockerfile -- -- main :: IO () -- main = writeFile "something.dockerfile" $ toDockerfileStr $ do -- from (tagged "fpco/stack-build" "lts-6.9") -- add "." "/app/language-dockerfile" -- workdir "/app/language-dockerfile" -- run (words "stack build --test --only-dependencies") -- cmd (words "stack test") -- @ toDockerfileStr :: EInstructionM a -> String toDockerfileStr = PrettyPrint.prettyPrint . toDockerfile untagged :: String -> EBaseImage untagged = EUntaggedImage tagged :: String -> String -> EBaseImage tagged = ETaggedImage digested :: String -> ByteString -> EBaseImage digested = EDigestedImage ports :: [Integer] -> Syntax.Ports ports = Syntax.Ports port :: Integer -> Syntax.Ports port = Syntax.Ports . (:[]) run :: MonadFree EInstruction m => String -> m () run = runArgs . words entrypoint :: MonadFree EInstruction m => String -> m () entrypoint = entrypointArgs . words cmd :: MonadFree EInstruction m => String -> m () cmd = cmdArgs . words -- | 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 => EInstructionM a -> m () onBuild b = mapM_ (onBuildRaw . Syntax.instruction) (toDockerfile b) -- | A version of 'toDockerfile' which allows IO actions toDockerfileIO :: MonadIO m => EInstructionTM m t -> m Syntax.Dockerfile toDockerfileIO e = liftM snd (runDockerfileIO e) -- | A version of 'toDockerfileStr' which allows IO actions toDockerfileStrIO :: MonadIO m => EInstructionTM m t -> m String toDockerfileStrIO e = liftM snd (runDockerfileStrIO e) -- | Just runs the EDSL's writer monad runDockerfileIO :: MonadIO m => EInstructionTM m t -> m (t, Syntax.Dockerfile) runDockerfileIO e = do (r, w) <- runWriterT (runDockerWriterIO e) return (r, map instructionPos w) -- | Runs the EDSL's writer monad and pretty-prints the result runDockerfileStrIO :: MonadIO m => EInstructionTM m t -> m (t, String) runDockerfileStrIO e = do (r, w) <- runDockerfileIO e return (r, PrettyPrint.prettyPrint w)