Go to Qiita Advent Calendar 2024 Top
LoginSignup
14
7

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@t10471inMercari

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

Last updated at Posted at 2017-04-25

ちょっとしたこと(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を連結して fromText で FilePath にもどしています。
view は以下の型で標準出力にコマンドの結果を出力します。
また、tutleで使われる FilePath は system-filepath 由来のものです。

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

{-# LANGUAGE OverloadedStrings #-}
import           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

型でコマンドの引数を定義出来るライブラリです。
結構詳細な説明があるのであんまり説明することはないのですが、以下のような感じで使います。

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

ヒアドキュメントを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

その名の通りのバリデーション用のライブラリです。
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

以下のような定義を書くだけで、復元と保存が出来るようになります。
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 で保存できますが、使うFilePath が Prelude のものなので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: []
14
7
2

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
14
7

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?