dhrun-1.0.1: app/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

{-|
Module      : dhall-exec.hs
Description : dhall-exec main app file.
Copyright   : (c) Valentin Reis, 2018
License     : MIT
Maintainer  : fre@freux.fr
-}

module Main
  ( main
  )
where

import           Protolude

import qualified Prelude
                   ( print )
import           Dhrun.Types.Cfg                                   as DI
import           Dhrun.Run                                         as DR
import           Options.Applicative                               as OA
import           Dhall
import           System.FilePath.Posix
import           System.Directory
import           GHC.IO.Encoding
import qualified System.IO                                         as SIO
import qualified Data.ByteString                                   as B
                   ( getContents )
import           Text.Editor

main :: IO ()
main = do
  GHC.IO.Encoding.setLocaleEncoding SIO.utf8
  join . customExecParser (prefs showHelpOnError) $ info
    (helper <*> opts)
    (fullDesc <> header "dhrun" <> progDesc
      (  "dhall-configured concurrent process execution"
      <> " with streaming assertion monitoring"
      )
    )

data MainCfg = MainCfg
  { inputfile    :: Maybe Text
  , stdinType    :: SourceType
  , verbosity    :: Verbosity
  , edit :: Bool
}

commonParser :: Parser MainCfg
commonParser =
  MainCfg
    <$> optional
          (strArgument
            (  metavar "INPUT"
            <> help
                 "Input configuration with .yml/.yaml/.dh/.dhall extension. Leave void for stdin (dhall) input."
            )
          )
    <*> flag
          Dhall
          Yaml
          (long "yaml" <> short 'y' <> help
            "Assume stdin to be yaml instead of dhall."
          )
    <*> flag Normal
             Verbose
             (long "verbose" <> short 'v' <> help "Enable verbose mode.")
    <*> flag
          False
          True
          (long "edit" <> short 'e' <> help "Edit yaml in $EDITOR before run.")

opts :: Parser (IO ())
opts =
  hsubparser
    $  command
         "run"
         (info (run <$> commonParser) $ progDesc "Run a dhrun specification.")
    <> command
         "print"
         ( info (printY <$> commonParser)
         $ progDesc "Print a dhrun specification."
         )
    <> help "Type of operation to run."


data SourceType = Dhall | Yaml deriving (Eq)
data FinallySource = NoExt | FinallyFile SourceType Text | FinallyStdin SourceType
ext :: SourceType -> Maybe Text -> FinallySource
ext _ (Just fn) | xt `elem` [".dh", ".dhall"] = FinallyFile Dhall fn
                | xt `elem` [".yml", ".yaml"] = FinallyFile Yaml fn
                | otherwise                   = NoExt
  where xt = takeExtension $ toS fn
ext st Nothing = FinallyStdin st

load :: MainCfg -> IO Cfg
load MainCfg {..} =
  (if edit then editing else return)
    =<< overrideV
    <$> case ext stdinType inputfile of
          (FinallyFile Dhall filename) ->
            (if v then detailed else identity)
              $   inputCfg
              =<< toS
              <$> makeAbsolute (toS filename)
          (FinallyFile Yaml filename) ->
            decodeCfgFile =<< toS <$> makeAbsolute (toS filename)
          (FinallyStdin Yaml) -> B.getContents <&> decodeCfg >>= \case
            Left  e   -> Prelude.print e >> die "yaml parsing exception."
            Right cfg -> return cfg
          (FinallyStdin Dhall) -> B.getContents >>= inputCfg . toS
          NoExt                -> die
            (  "couldn't figure out extension for input file. "
            <> "Please use something in {.yml,.yaml,.dh,.dhall} ."
            )
 where
  v = verbosity == Verbose
  overrideV x = x
    { DI.verbosity = if (DI.verbosity x == Verbose) || v
                       then Verbose
                       else Normal
    }

editing :: Cfg -> IO Cfg
editing c = runUserEditorDWIM yt (encodeCfg c) <&> decodeCfg >>= \case
  Left  e   -> Prelude.print e >> die "yaml parsing exception."
  Right cfg -> return cfg
  where yt = mkTemplate "yaml"

run :: MainCfg -> IO ()
run c = load c >>= DR.runDhrun

printY :: MainCfg -> IO ()
printY c = load c >>= putText . toS . encodeCfg