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


ちょっとしたこと(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` も設定します。 

```Haskell
{-# 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` 由来のものです。

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

```Haskell
{-# 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` をつけてい実行します。

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

```Haskell
{-# 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の戻り値はステータスコードなので戻り値を取得出来ません。

 ```Haskell
 inshell :: Text -> Shell Line -> Shell Line
 ``` 


```Haskell
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

型でコマンドの引数を定義出来るライブラリです。
結構詳細な[説明](http://blog.mudatobunka.org/entry/2016/12/11/140845)があるのであんまり説明することはないのですが、以下のような感じで使います。

```Haskell
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というバイナリでコンパイルした場合)

```shell
$ 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で記述出来るライブラリです。
コマンドを複数実行したい場合に重宝します。
これも、[詳しい説明](http://qiita.com/cutsea110/items/4eb22cbb3f874436d33f)があるので、特に言うこともないのです...
if文や変数が使えてとても便利です。
ただ、変数が `${x}` みたいな感じになるのでshellの変数とごっちゃになりやすいです...

```Haskell
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](https://hackage.haskell.org/package/either-4.4.1.1/docs/Data-Either-Validation.html)というシンプルなValidationもありますが、今回紹介するのはちょっと複雑なもので、以下のような型を持っています。

* AccValidation
  - AplicativeなValidation
* Validation
  - MonadなValidation
* ValidationT
  - monad transformerなValidation
* ValidationB
  - bifunctorなValidation

[example](https://github.com/NICTA/validation/tree/master/examples/src)を見て型に対してvalidationをすることができるみたいだったので、使ったのですが、
shellで使うようなものはあんまり型として定義する必要が無かったので、ちょっとオーバースペックかもしれません。
(lensを使っているのでインストールが遅い...)

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

```haskell
{-# 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を行うサンプルです。
関数は上で定義したものを使っています。

```Haskell
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になります。

```haskell
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と使う時は変換しなければなりません。

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

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

```haskell
import           Prelude hiding (FilePath)
import qualified Prelude as P (FilePath)

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

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

```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とかあるので、作ってからこれ要らないなって思ったんですが...

```Haskell
{-# 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ファイル

```yaml
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

```Haskell
resolver: lts-8.12

packages:
- '.'

extra-deps:
- optparse-declarative-0.3.0

flags: {}

extra-package-dbs: []
```