EDSL.hs

{-# 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)