Edited at

HaskellでShellみたいなことをやるのに便利なライブラリの紹介

More than 1 year has passed since last update.

ちょっとしたこと(buildやdeploy等)をshell(bash)でやっていることが多いのですが、

shellで思ったようにプログラミングできないなーって思うことがちょくちょくあります。

特にバリデーションやステータスの確認をきちんとやりつつモジュール化みたいなことをやろうとすると

結構shellではつらかったりします。

shellのつらいところ


  • 関数に変数を渡したら空白が入って思った通りに引数を渡せない

  • 関数から戻り値を貰いたいけど面倒なのでグローバル変数で受け取る

  • $()内でエラーが起きた場合のハンドリングをちゃんとやるのがつらい

(私のshell力が低いのが多分にありますが...)

ちょっとしたことなので、好きな言語でやっちゃえば良いんじゃない?

という軽い気持ちでHaskellでやる場合の便利ライブラリを紹介します。

(個人的にはPythonとかRubyでやるのが良いような気がします)

紹介するのは以下のライブラリになります。


  • turtle

  • optparse-declarative

  • heredocs

  • validation


turtle

https://hackage.haskell.org/package/turtle

shellコマンドを関数として持っているライブラリです。

shellyというのもありますが、turtleの方が後発で使いやすそうな感じがしたのでこっちを使っています。

ちゃんとTutorialがついているので説明することはないのですが、超簡単な使い方を説明します。


echo

turtleは文字列として Data.Text を使う必要があります。

そのため、OverloadedStrings も設定します。

{-# LANGUAGE OverloadedStrings #-}

port Turtle
import qualified Data.Text as Text

main = do
echo "Hello, world!"


ファイルを作成

ホームディレクトリにtest.txtというファイルを作って、lsするサンプルです。

format fp h でFilePathをTextに変換します。それからtext.txtを連結して fromTextFilePath にもどしています。

view は以下の型で標準出力にコマンドの結果を出力します。

また、tutleで使われる FilePathsystem-filepath 由来のものです。

view :: (Show a, MonadIO io) => Shell a -> io ()

{-# LANGUAGE OverloadedStrings #-}

port Turtle
import qualified Data.Text as Text

main = do
h <- home
touch $ fromText $ (format fp h) <> "/test.txt"
view (ls h)


コマンドを実行する

コマンドを実行するには下記のように行います。

コマンドの実行は主に shell を通して行います。

shellは以下の型で連続して実行出来るようになっているので、単独で実行する時は empty をつけてい実行します。

shell :: MonadIO io => Text -> Shell Line -> io ExitCode

{-# LANGUAGE OverloadedStrings #-}

import Turtle
import qualified Data.Text as Text

exec :: (MonadIO m) => Text -> m ()
exec cmd = do
x <- shell cmd empty
case x of
ExitSuccess -> return ()
ExitFailure n -> die (cmd <> " failed with exit code: " <> repr n) >> return ()


コマンドの結果を取得する

結果を取得するには少し手間でfoldを使う必要があります。

inshell は以下の型です。shellの戻り値はステータスコードなので戻り値を取得出来ません。

 inshell :: Text -> Shell Line -> Shell Line

import qualified Control.Foldl as Fold

get :: (MonadIO m) => Text -> m (Maybe Line)
get cmd = do
fold (inshell cmd empty) Fold.head


optparse-declarative

https://hackage.haskell.org/package/optparse-declarative

型でコマンドの引数を定義出来るライブラリです。

結構詳細な説明があるのであんまり説明することはないのですが、以下のような感じで使います。

deploy :: Flag "e" '["exec"] "BOOL" "execute deploy" Bool

-> Flag "
n" '["env"] "ENV" "deploy env" String
-> Flag "
c" '["color"] "COLOR" "deployment color" String
-> Arg "
CONTAINER" String
-> Cmd "
Deploy container" ()
deploy = undefined

main = run_ deploy

Flag でオプションを指定して、 Arg で引数を指定します。

このサンプルだと以下のように実行出来ます。

(mainというバイナリでコンパイルした場合)

$ main -e -n stage -c blue api

# or
$ main --exec --env stage --color blue api

はまった点としては以下のようなことがあります。



  • Arg は1つしかとることが出来ない

  • デフォルトで v V ? が予約されている

また、turtleは Data.Text で、optparse-declarativeは String なので変換する必要があります...


heredocs

https://hackage.haskell.org/package/heredocs

ヒアドキュメントをHaskellのTemplateで記述出来るライブラリです。

コマンドを複数実行したい場合に重宝します。

これも、詳しい説明があるので、特に言うこともないのです...

if文や変数が使えてとても便利です。

ただ、変数が ${x} みたいな感じになるのでshellの変数とごっちゃになりやすいです...

import           Text.Heredoc (heredoc)

clean :: Text -> Text
clean uri = [heredoc|
docker images --format "{{.ID}}\t{{.CreatedAt}}\t{{.Tag}}" ${uri} | \
sort -r -k2,3 | \
awk -F"\t" '$3 != "latest" && NR > 3 {print $1}' | \
xargs -n 1 docker rmi -f || true
|]


validation

https://hackage.haskell.org/package/validation

その名の通りのバリデーション用のライブラリです。

Data-Either-ValidationというシンプルなValidationもありますが、今回紹介するのはちょっと複雑なもので、以下のような型を持っています。


  • AccValidation


    • AplicativeなValidation



  • Validation


    • MonadなValidation



  • ValidationT


    • monad transformerなValidation



  • ValidationB


    • bifunctorなValidation



exampleを見て型に対してvalidationをすることができるみたいだったので、使ったのですが、

shellで使うようなものはあんまり型として定義する必要が無かったので、ちょっとオーバースペックかもしれません。

(lensを使っているのでインストールが遅い...)

以下はTargetという型に対してのValidationをするサンプルです。

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Lens
import Data.List
import Data.Validation (_Success, _Failure, AccValidation(AccSuccess, AccFailure))
import qualified Data.Text as Text
import Turtle

type Field = String
type Value = String
type Message = String
type Error = String
type Validated a = AccValidation [Error] a
type Rule = Field -> Value -> Validated Value

data Target = Target String deriving (Show, Eq)

validateTarget :: (MonadIO m) => Target -> [Value] -> m Target
validateTarget target values = case evaluate target values of
AccFailure errors -> die (conv errors)
AccSuccess target -> return target
where
conv errors = foldr (<>) Text.empty $ map Text.pack errors
evaluate (Target value) values = validates "Target" [notEmpty, include values] Target value

validates :: Field -> [Rule] -> (Value -> a) -> Value -> Validated a
validates name rules constructor value = constructor <$> validate name rules value

validate :: Field -> [Rule] -> Value -> Validated Value
validate name rules value = head <$> sequenceA (map (\f -> f name) rules <*> [value])

mkErrors :: Field -> Value -> Message -> [Error]
mkErrors name value message = [name ++ "[" ++ value ++ "]: " ++ message ++ " "]

notEmpty :: Rule
notEmpty name value
| value /= "" = _Success # value
| otherwise = _Failure # mkErrors name value "empty string is not allowed"

include :: [Value] -> Rule
include list name value
| elem value list = _Success # value
| otherwise = _Failure # _mkErrors list name value
where _mkErrors list name value = mkErrors name value
$ "expected values [" ++ intercalate "," list ++ "]"

main :: IO ()
main = do
target' <- validateTarget goodTarget params
target' <- validateTarget badTarget params
return ()
where
params = ["better", "good", "best"]
goodTarget = Target "good"
badTarget = Target "bad"

型を定義しないで複数のValidationを行うサンプルです。

関数は上で定義したものを使っています。

validateEtc :: (MonadIO m) => Value -> Value -> m ()

validateEtc color container =
case pure () <* vdColor <* vdContainer of
AccFailure errors -> die (conv errors)
AccSuccess _ -> return ()
where
vdColor = validate "color" [notEmpty, include colors] color
vdContainer = validate "container" [notEmpty, include containers] container
conv errors = foldr (<>) Text.empty $ map Text.pack errors
colors = ["blue", "green"]
containers = ["front", "api", "cache", "prediction"]


本当は作ったものをまるっと紹介したいのですが、なかなか仕様がややこしくて説明するのが大変なので、

あんまり説明のいらないところをサンプルとして乗せておきます。(heredocsは使ってないのですが...)

下のプログラムは環境変数をグループで登録して切り替えられるツールです。

下記3つのコマンドがあり、環境変数は~/.myenv.yamlに保存しています。


  • envshow 登録しているグループと値の一覧を表示

  • envswitch グループを切り替える

  • envput 環境変数をグループに登録する

上記ライブラリ紹介に出ていない Data.Yaml も使っています。

思ったより情報がなさそうだったので、ちょっとだけ説明します。


yaml

https://hackage.haskell.org/package/yaml

以下のような定義を書くだけで、復元と保存が出来るようになります。

aeson由来の定義を使っているのでFromJSON、ToJSONになっていますが、Yamlになります。

import           Data.Yaml (FromJSON, ToJSON)

import qualified Data.Yaml as Y
import GHC.Generics

data EnvRoot = EnvRoot { env_root :: HashMap String EnvMap }
deriving (Eq, Show, Generic)
instance FromJSON EnvRoot
instance ToJSON EnvRoot

data EnvMap = EnvMap { env_map :: HashMap String String }
deriving (Eq, Show, Generic)
instance FromJSON EnvMap
instance ToJSON EnvMap

あと、下記の型を持った encodeFile で保存できますが、使うFilePathPrelude のものなのでturtleと使う時は変換しなければなりません。

encodeFile :: ToJSON a => FilePath -> a -> IO ()

ちょっと別名でインポートする方法に悩みました...

import           Prelude hiding (FilePath)

import qualified Prelude as P (FilePath)

cvFilePath :: FilePath -> P.FilePath
cvFilePath f = Text.unpack $ format fp f

保存されるyamlは以下のようになります。

env_root:

other:
env_map:
TEST_VALUE: other_test
ROOT_PATH: /Users/other/
default:
env_map:
TEST_VALUE: default_test
ROOT_PATH: /Users/default/

まぁ、envdirとかあるので、作ってからこれ要らないなって思ったんですが...

{-# LANGUAGE DataKinds           #-}

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Lens
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Text
import Data.Validation (_Success, _Failure, AccValidation(AccSuccess, AccFailure))
import Data.Yaml (FromJSON, ToJSON)
import qualified Data.Yaml as Y
import GHC.Generics
import Options.Declarative (get, run_, subCmd, Arg, Cmd, Flag, Group(..))
import Prelude hiding (FilePath)
import qualified Prelude as P (FilePath)
import Turtle

data EnvRoot = EnvRoot { env_root :: HashMap String EnvMap }
deriving (Eq, Show, Generic)
instance FromJSON EnvRoot
instance ToJSON EnvRoot

data EnvMap = EnvMap { env_map :: HashMap String String }
deriving (Eq, Show, Generic)
instance FromJSON EnvMap
instance ToJSON EnvMap

envshow :: Cmd "Show passed env's map" ()
envshow = do
b <- hasFile
when (not b) $ die ("yaml not exists") >> return ()
f <- liftIO $ getFilePath
r <- liftIO $ (Y.decodeFile (cvFilePath f) :: IO (Maybe EnvRoot))
case r of
Nothing -> die ("yaml parse error") >> return ()
Just r -> showList r
where
showList root = mapM_ _show $ HashMap.toList $ env_root root
_show (k, ls) = do
liftIO $ putStrLn $ "env = " ++ k
mapM_ _print $ HashMap.toList $ env_map ls
_print (k, v) = liftIO $ putStrLn $ " " ++ k ++ " = " ++ v

envswitch :: Arg "Group" String
-> Cmd "Swith env Group" ()
envswitch group = do
b <- hasFile
when (not b) $ die ("yaml not exists") >> return ()
f <- liftIO $ getFilePath
r <- liftIO $ (Y.decodeFile (cvFilePath f) :: IO (Maybe EnvRoot))
case r of
Nothing -> die ("yaml parser error") >> return ()
Just r -> switch r (get group)
where
switch root group = do
_export root group
liftIO $ echo "# Run this command to configure your shell:"
liftIO $ echo "# eval $(mycmd envswitch group)"
_export root group = case HashMap.lookup group (env_root root) of
Nothing -> die (Text.pack group <> " is undefined") >> return ()
Just m -> mapM_ _print $ HashMap.toList $ env_map m
_print (k, v) = liftIO $ putStrLn $ "export " ++ k ++ "=" ++ v

envput :: Flag "k" '["key"] "KEY" "env key" String
-> Flag "
a" '["value"] "VALUE" "env value" String
-> Arg "
Group" String
-> Cmd "
Put to env" ()
envput key value group = do
validatePut (get key) (get value) (get group)
b <- hasFile
when (not b) $ createFile
f <- getFilePath
r <- liftIO $ (Y.decodeFile (cvFilePath f) :: IO (Maybe EnvRoot))
case r of
Nothing -> die "
yaml is broken" >> return ()
Just r -> updateYaml r (get key) (get value) (get group)

updateYaml :: (MonadIO m) => EnvRoot -> String -> String -> String -> m ()
updateYaml root key value group = do
f <- getFilePath
liftIO $ Y.encodeFile (cvFilePath f) EnvRoot {env_root = update $ env_root root}
where
update er = HashMap.alter (\x -> Just $ _update er) group er
_update er = case HashMap.lookup group er of
Nothing -> EnvMap {env_map = HashMap.fromList [(key, value)]}
Just eMap -> EnvMap {env_map = _alter eMap}
_alter em = HashMap.alter (
\x -> Just value) key $ env_map em

createFile :: (MonadIO m) => m ()
createFile = do
f <- getFilePath
liftIO $ touch f
liftIO $ Y.encodeFile (cvFilePath f) EnvRoot {env_root = HashMap.empty}

getFilePath :: (MonadIO m) => m FilePath
getFilePath = do
h <- home
return $ fromText $ (format fp h) <> "/.myenv.yaml"

cvFilePath :: FilePath -> P.FilePath
cvFilePath f = Text.unpack $ format fp f

hasFile :: (MonadIO m) => m Bool
hasFile = do
f <- getFilePath
testfile f

type Field = String
type Value = String
type Message = String
type Error = String
type Validated a = AccValidation [Error] a
type Rule = Field -> Value -> Validated Value

validatePut :: (MonadIO m) => Value -> Value -> Value -> m ()
validatePut key value group =
case pure () <* vdKey <* vdValue <* vdGroup of
AccFailure errors -> die (conv errors)
AccSuccess _ -> return ()
where
vdKey = validate "key" [notEmpty] key
vdValue = validate "
value" [notEmpty] value
vdGroup = validate "
group" [notEmpty] group
conv errors = foldr (<>) Text.empty $ map Text.pack errors

validate :: Field -> [Rule] -> Value -> Validated Value
validate name rules value = head <$> sequenceA (map (\f -> f name) rules <*> [value])

mkErrors :: Field -> Value -> Message -> [Error]
mkErrors name value message = [name ++ "[" ++ value ++ "]: " ++ message ++ " "]

notEmpty :: Rule
notEmpty name value
| value /= "" = _Success # value
| otherwise = _Failure # mkErrors name value "empty string is not allowed"

main :: IO ()
main = run_ $
Group "env tool commands"
[ subCmd "
envshow" envshow
, subCmd "
envput" envput
, subCmd "
envswitch" envswitch
]

cabalファイル

name:                envcmd

version: 0.1.0.0
license: BSD3
license-file: LICENSE
copyright: MIT
category: App
build-type: Simple
cabal-version: >=1.10

executable envcmd
hs-source-dirs: app
main-is: Main.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base >= 4.7 && < 5
, lens
, text
, turtle
, validation
, unordered-containers
, optparse-declarative
, yaml
default-language: Haskell2010

stack.yaml

resolver: lts-8.12

packages:
- '.'

extra-deps:
- optparse-declarative-0.3.0

flags: {}

extra-package-dbs: []