Haskell Scottyをapache転送で外向けに

 内部LANでのサーバ稼働はうまくいったので、外向けに以前設定したraspi2のapache転送をそのまま利用することにした。ただ、これも一筋縄でいかなかった。（クッキーを利用する場合は、転送処理は難しいようなので、あくまで簡易的な利用にとどめる予定）

・sudo nano /etc/apache2/sites-available/default-ssl.confで、以下のような行を追加

ProxyPass /hs http://追加ラズパイのローカルipアドレス:3000

これで、外部からsslでhttps://ホスト.ドメイン/hsでアクセスすると追加raspi3の3000ポートに転送される。

他に苦労したところでは、

・raspi間の転送がうまくいくように、ルータのipフィルタリングの許可設定を追加

・webアプリに0,0,0,0でリスンするようにコードを書き換える必要があった。そうしないと、なぜか転送がうまくいかなかった。なお、キャッシュが残っているとうまくいかないこともあるので、ビルド、ブラウザは適宜、キャッシュクリアの操作が必要かも。あと、warpを.yamlに追加する必要があった。

  app/Main.hs

{-# LANGUAGE OverloadedStrings #-} module Main(main) where import Web.Scotty import Network.Wai.Handler.Warp (defaultSettings, setPort, setHost) main :: IO () main = do let warpSettings = setPort 3000 $ setHost "0.0.0.0" defaultSettings scottyOpts (Options 1 warpSettings) $ do get "/" $ html "<h1>Hello</h1>" get "/bye" $ html "<h1>Goodbye</h1>"

Haskell入門 Ｗｅｂアプリ(覚書）

 １０章のＷｅｂアプリを読み終えたのはいいけれど、Spockは実際にビルドしても、依存関係のエラーでかなり面倒なことが判明。いろいろ、バージョンを変えて調整したが、ネット上の情報も少なく諦める。せっかくのSpockの勉強も無駄？になったようで、ちょっと回り道してしまった感じもある。

　とりあえず、Scottyあたりが、比較的メンテもされているようなので、そちらを試すことにした。まずは、簡単なコードをしばらくしまい込んでいたraspi3で、動作確認をしてみた。

・stack new sample           cd sample
・package.yamlについて:   executables>sample-exe>dependenciesに
    - sample
    - http-types
    - aeson
    - scotty

・Main.hsについて
　 {-# LANGUAGE OverloadedStrings #-} module Main where import Web.Scotty main :: IO () main = scotty 3000 $ do get "/" $ html "<h1>Hello</h1>" get "/bye" $ html "<h1>Goodbye</h1>"

・stack build       stack install
    stack exec sample-exe   でhttp://raspiのアドレス:3000/でアクセス

これで、ようやく動作の確認はできた。

    ちなみにコード修正後はstack runで　　ビルドと実行ができるようだ

     stack cleanでビルド結果を削除（再ビルドしたいとき）

Haskell入門P368 ルーティング、本体

HaskellでSpockを使ったルーティングは、慣れるまで大変そうですが、無駄のない構成という感じがします。

-- src/Web/WeightRecorder.hsに追記。 authHook :: WRAction WRContext authHook = do ctx <- getContext mUser <- fmap wrsesUser readSession case mUser of Nothing -> startView Nothing Just user -> return $ ctx { wrconUser = Just user } -- src/Web/WeightRecorder.hsに追記。 -- ルーティング定義。 spockApp :: WRApp () () spockApp = prehook (return emptyContext) $ do prehook authHook $ do get root $ mainView Nothing post "new_record" newRecordAction post "register" registerAction post "login" loginAction -- src/Web/WeightRecorder.hsに追記。 weightRecorderMiddleware :: WRConfig -> IO WAI.Middleware weightRecorderMiddleware cfg = do -- テンプレートの読み込み。 starttpl <- loadStartTemplate cfg maintpl <- loadMainTemplate cfg -- 状態を作成。 let state = WRState { wrstStartTemplate = starttpl , wrstMainTemplate = maintpl } pool <- sqlitePool $ wrcDBPath cfg -- セッションと状態を渡して設定を作成。 spCfg <- defaultSpockCfg emptySession (PCPool pool) state spock spCfg spockApp -- 生成。 -- src/Web/WeightRecorder.hsに追記。 sqlitePool :: FilePath -> IO (Pool Connection) sqlitePool dbpath = createPool (connectSqlite3 dbpath) disconnect 1 60 5 -- src/Web/WeightRecorder.hsに追記。 runWeightRecorder :: WRConfig -> IO () runWeightRecorder cfg = runSpock (wrcPort cfg) (weightRecorderMiddleware cfg)

authHook:ログイン認証

・ctx <- getContextについて：ユーザーからのリクエスト関連情報が、ある時点で箱にはいっていて、そこから、とりだしたのがctxへいく、というイメージ。

・mUser <- fmap wrsesUser readSessionについて：オブジェクトにフィールド名を関数として適用すると、該当フィールドの要素を返す仕組みになっている(P96).

readSession :: WRAction (SessionVal UserSession):現在のリクエストに紐づく セッション情報 を取得する関数 data UserSession = UserSession { wrsesUser :: Maybe User....から、取り出しmUserに

spockApp:ルーティング

・外側のprehookは認証なし、内側はauthHookで認証　うまく階層的に配置してわかりやすい構造

・get,postの別やURLと対応するActionが並べられている。

prehook (return emptyContext) $

 ├─ prehook authHook $ do

 │    ├─ get root

 │    └─ post "new_record"

 ├─ post "register"       ← authHook は適用されない

 └─ post "login"          ← authHook は適用されない

weightRecorderMiddleware:WAI ミドルウェアとして起動するための処理

・runWeightRecorder cfgで定義されているように、runSpockで呼ばれる。

  　　ここで、spock spCfg spockApp にreturnがないが、do内のモナド計算なので不要

Haskell入門 P364 グラフ表示部の実装

-- グラフ表示の実装。 weightGraphValue :: [WRecord.WeightRecord] -> WRAction [Value] weightGraphValue wrs = do flatWrs <- liftIO $ mapM flat wrs let wrss = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ flatWrs return $ map groupToValue wrss where -- WeightRecord型を日付と体重のタプルにして扱いやすくする。 flat wr = do ztime <- toZonedTime $ WRecord.time wr let ztimeStr = TM.formatTime TM.defaultTimeLocale "%m/%d" ztime w = WRecord.weight wr return (ztimeStr, w) -- グループをmustacheで扱うための値にする。 groupToValue gr = let dt = head $ map fst gr -- groupByの仕様からgrは[]ではなく、headが使える wt = avg $ map snd gr avg xs = sum xs / fromIntegral (length xs) in object ["day" ~> dt, "weight" ~> wt]

ここも、分かりにくいところがあり、ChatGPTの助けを借りるが、ほぼ完ぺきにわかりやすく説明してくれるので、非常に助かる。

・weightGraphValueはMustacheへ渡すValueを返すのが役目。

・liftIO $ mapM flat wrsについて：flatでweightはそのまま使い、日付のみ"%m/%d"形式に変換し、 flat::WeightRecord-> IO (String,Double)　よりmapM flat wrsはIO[(String,Double)]を返す。このへんは、mapMの働きを覚えてないと使えない、正直言って、前に学習(P174)したことを忘れており、復習して気づいた感じ。IOを含んでいるのでliftIOでWRActionモナドに持ち上げている。

・let wrss = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ flatWrsについて:

 sortBy (compare `on` fst) は、fstの日付でソートしている。groupBy ((==) `on` fst) は同じ日付のものをまとめるらしい。つまり[ [("08/20",60.5), ("08/20",61.0)],  [("08/21",60.8)]となる。wrssはリストのリストになります。(==)にそういう機能があることなど、非常に細かいところだけどChatGPTがしっかり解説してくれたのには、驚いた。

　本によれば、onは第二引数の関数を適用してから、第一引数の２項演算子を適用するという働きらしい。これと、上記の説明をみて、ようやく意味が理解できた。

・groupToValueについて：　　:: [(String, Double)] -> Valueである。

 　　dt = head $ map fst gr→ グループの日付を取り出す（全部同じなので先頭でOK）。

　　 wt = avg $ map snd gr→ 複数記録がある場合は平均を取る。

　なるほど、うまくでてきています。これを使えばgroupToValue [("08/20",60.5),("08/20",61.0)]→ object ["day" ~> "08/20", "weight" ~> 60.75]となります。

Haskell入門 P354 各種操作の実装

registerAction :: WRAction a registerAction = do name <- param' "name" -- paramで値を取り出す。 password <- param' "password" when (null name || null password) $ startView (Just "入力されてない項目があります") -- 未入力項目があれば入力を促す。 n <- runSqlite $ insertUser (NewUser name password) when (n <= 0) $ startView (Just "登録に失敗しました") -- INSERT失敗時に登録失敗を返す。 startView (Just "登録しました。ログインしてください。")

whenはtrueならアクションを実行、startViewは実行したら次の行にはいかない。

runSqlite で　(Connection -> IO m)を引数にとるため、insertUserの部分適用をうまく使っている。　(insertUser  :: IConnection c  => NewUser -> c -> IO Integerなので)

このへんがHaskellの簡潔さにつながっているのだと思う。

Haskell入門 P352 コントローラの開発

P352「type WRApp ctx= SpockCtxN ctx WRConnection WRSession WRState

type WRAciton = SpockActionCtx WRCibtext WRConnection WRSession WRState

WRAppとWRActionはWeightRecoder アプリケーションで利用するモナドです。
先ほどコンテキストにはWRContextを使うものとしてsrc/Web/Core.hsに定義しました。
　しかし、/のコンテキストは必ず()になるため、WRContextは適しません。そのため、ルーティングに用いるWRAppでは()にも対応できるよう、ctxを指定できるよう定義しています。一方で、ロジックを実際に記述するWRActionのコンテキストは、()を受け取らないようにできるため、型変数ではなくWRContext固定としています。このため、ルーティングの根本でコンテキストをWRContextに設定する必要があります。」

　この部分がよくわからなかった。どうやら、型変数ctxの例がWRContextという型などであるようだ。WRappとWRActionは厳密に関連しているのかと思ったけれど、必ずしもそういうことではなかったよう。WRAction が型変数をとらない理由は、型を固定して型安全にしたいからのよう。WRApp はルートや URL ごとに ctx が異なる可能性があるので型変数で柔軟にしている。そういうことらしい。WRappは設定データだから、いろんなデータを設定できる方がいい、でもWRActionは、安全性が求められるのである程度使える設定データは制限したい、そんな感じだろうか。

Haskell入門 P347 ユーザー登録のためのINSERT

 仕組みがわかりにくかった。

module Model.User ( NewUser(NewUser, nuName, nuPassword) , nuName' , nuPassword' , insertUser , selectUser ) where -- import 省略 data NewUser = NewUser { nuName :: !String , nuPassword :: !String } makeRecordPersistableDefault ''NewUser -- 射影を定義。 piNewUser :: HRR.Pi User.User NewUser piNewUser = NewUser HRR.|$| User.name' HRR.|*| User.password' -- src/Model/User.hsに追記。 -- 第一引数で新ユーザ、第二引数で接続を指定。 insertUser :: IConnection c => NewUser -> c -> IO Integer insertUser u conn = do mHashed <- -- ハッシュ生成。第一引数はハッシュ化ポリシー設定。 hashPasswordUsingPolicy slowerBcryptHashingPolicy $ enc . nuPassword $ u case mHashed of -- ハッシュ生成失敗の場合。 Nothing -> do hPutStrLn stderr "Failed to hash password" return 0 -- ハッシュ生成成功の場合。 Just hashed -> do let ins = HRR.typedInsert User.tableOfUser piNewUser u' = u { nuPassword = dec hashed } -- トランザクション維持。 withTransaction conn $ \conn' -> -- ここでINSERT文実行。 DHR.runInsert conn' ins u' `catch` \e -> do hPrint stderr (e :: SqlError) return 0 -- ハッシュ化した情報を取り扱うエンコーダとデコーダ。 enc :: String -> BS.ByteString enc = encodeUtf8 . pack dec :: BS.ByteString -> String dec = unpack . decodeUtf8 -- src/Model/User.hsに追記。 -- 第一引数にユーザ名、第二引数にパスワード、第三引数に接続を指定。 selectUser :: IConnection c => String -> String -> c -> IO (Maybe User.User) selectUser name pass conn = do -- runQueryでクエリ実行で情報取り出し、listToUniqueでリストを一意に。 user <- DHR.runQuery conn q name >>= DHR.listToUnique return $ user >>= checkHash where -- 関数の性格上、where以下に定義する。 -- クエリの定義 q :: HRR.Query String User.User q = HRR.relationalQuery . HRR.relation' . HRR.placeholder $ \ph -> do a <- HRR.query User.user HRR.wheres $ a HRR.! User.name' HRR..=. ph return a -- ハッシュをチェックする。 checkHash :: User.User -> Maybe User.User checkHash user | validated = Just user | otherwise = Nothing where hashed = User.password user -- ハッシュ化したパスワードとの照合。 validated = validatePassword (enc hashed) (enc pass)

そこで、次のような質問をChatGPTにしてみた。

Q1：piNewUserは、どういうふうに使い方をするのですか？

Ans: let ins = HRR.typedInsert User.tableOfUser piNewUser がポイント

typedInsert :: Table User -> Pi User NewUser -> Insert NewUser

第1引数 User.tableOfUser → 「Userテーブルそのもの」

第2引数 piNewUser → 「NewUser から User のカラムに対応付ける射影」

let ins = HRR.typedInsert User.tableOfUser piNewUser

    u'  = u { nuPassword = dec hashed }                ins は INSERT 文のひな型

DHR.runInsert conn' ins u'     と実行すると、

u' :: NewUser の値（ユーザー名とハッシュ済パスワード）を

piNewUser に従って User テーブルの name, password カラムに対応付け

実際に DB へ INSERT

Q2: 要するに、手順を最初にくみたてて、最後に、runInsertで実行するのですね。

Ans:  はい、その理解でバッチリです！

  まとめると：

   piNewUser で「どう射影するか」を定義（テーブルと型の橋渡し）。

   typedInsert で「INSERT文のひな型」を作成。

   runInsert で「実際の値」を流し込んでDBに送信。

※　Haskellは、手続き型のように「値を受け取りながら逐次SQL発行」というやり方はあまりせず、まず「設計図を型安全に作る → 値を流し込む」という 宣言的な流れ

　型安全性が高い：SQL文やカラム名の間違いをコンパイル時に検出できる

　SQLインジェクション対策が組み込みである：値を直接文字列連結しないので安全

　トランザクション管理が明確：withTransaction の中で設計図に値を流し込むので、途中でエラーがあればロールバック可能

　コードの再利用性が高い：射影（piNewUser のような定義）を作っておくと、INSERTや　　SELECTで同じマッピングを使い回せる

　などの利点があるらしい

Q3:makeRecordPersistableDefault ''NewUser　はどういう意味？

Ans:NewUser を Relational-Record の「DBに入出力できる型」として登録する宣言、Template Haskell によって必要な型クラスインスタンスを自動生成している

「この型をSQLに流せるようにしますよ！」と最初に宣言しておく儀式 みたいなもの

Q4:Template Haskellとは？（P340にも説明はありますが）

Ans:「Haskellプログラム自身を生成する Haskellプログラム」を書ける

Q5:自動生成ですね。DjangoやRuby on Railsなどでも、DB初期化で似たような処理あったような気がしますね.

Ans:まさに Django や Ruby on Rails と同じ発想です。

Rails/Django = 実行時に自動生成・マッピング

Haskell(TH) = コンパイル時に自動生成・型安全にマッピング

Q6:user <- DHR.runQuery conn q name >>= DHR.listToUniqueのDHR.listToUniqueの働きは？

Ans:[] の場合 → Nothing を返す、[x] の場合 → Just x を返す、[x, y, ...] の場合 → エラーか Nothing を返す。「DB側にユニーク制約があるとは限らない」設計を想定。

Q7:checkHash user | validated = Just user | otherwise = Nothingの意味は？

Ans: if ... else if ... else if ... elseのイメージで、最初にtrueになったところが　checkHash userの値。ガードの機能(p62で既習)

Haskell入門 P326 処理のまとめ

stack install で実行ファイルを作り、動作確認してみた。これも、一筋縄ではいかず、Windowsだと、文字エンコードなど配慮しないとうまくいかなかった。エラーメッセージ見たり、ChatGPTに聞いたりしながら、なんとか解決。

 

echo [{"age":"aa","name":"名前","telnumber":"abcdef"},"age":"bb","name":"abcd","telnumber":"jkl"}] > test.json

としてファイルをつくってから

hjq-exe "{\"name\":.[1].name,\"telnumber\":.[1].telnumber}" test.json

としたらうまくいった。ハイフンがあるとうまくいかず、カットする必要あった。なかなか、大変だった。

package.yamlのdependenciesは最終的にこのようになった dependencies: - base >= 4.7 && < 5 - text - megaparsec - aeson - lens - lens-aeson - vector - unordered-containers - errors - bytestring - aeson-pretty Hjq.hsは {-# LANGUAGE OverloadedStrings #-} module Data.Hjq ( hjq ) where import Control.Error.Util import Data.Aeson import Data.Text as T import Data.ByteString.Lazy as B import Data.Hjq.Parser import Data.Hjq.Query import Data.Aeson.Encode.Pretty import Data.Bifunctor (first) hjq :: B.ByteString -> T.Text -> Either T.Text B.ByteString hjq jsonString queryText = do value <- note "Invalid json format." $ decode jsonString query <- first T.pack $ parseJqQuery queryText -- String -> Either Text _ result <- executeQuery query value -- Either Text Value return $ encodePretty result Main.hsは module Main where import System.Environment import System.Exit import Data.Hjq import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import System.Exit (ExitCode(..)) main :: IO () main = do args <- getArgs case args of (q : file : []) -> do jsonLazy <- BL.readFile file printResult $ hjq jsonLazy (T.pack q) -- ここでは q が正しい (q : []) -> do jsonLazy <- BL.getContents printResult $ hjq jsonLazy (T.pack q) -- ここも q _ -> putStrLn "Invalid arguments" >> exitWith (ExitFailure 1) printResult :: Either T.Text BL.ByteString -> IO () printResult (Right s) = do BL.putStr s putStrLn "" -- 改行を追加 printResult (Left s) = do T.putStrLn s exitWith $ ExitFailure 1

Hjq.hs

・note:MaybeをEitherに変換　　　　decode:ByteStringをValueに変換

　first:Rightはそのまま、Leftに関数を適用

Haskell入門 P323 テストようやく終了

 本のままでは、動かず新しいバージョンに合わせた修正が必要だった。

-- Spec.hs ********************* {-# LANGUAGE OverloadedStrings #-} import Test.HUnit import qualified Data.Text() import Data.Text (Text,unpack) import Data.Hjq.Parser import Data.Hjq.Query(applyFilter,executeQuery) -- import qualified Data.HashMap.Strict as H import qualified Data.Vector as V import Data.Aeson import qualified Data.Aeson.KeyMap as KM import Control.Lens import Data.Aeson import Data.Aeson.Lens jqFilterParserTest :: Test jqFilterParserTest = TestList [ "jqFilterParser test 1" ~: parseJqFilter "." ~?= Right JqNil , "jqFilterParser test 2" ~: parseJqFilter ".[0]" ~?= Right (JqIndex 0 JqNil) , "jqFilterParser test 3" ~: parseJqFilter ".fieldName" ~?= Right (JqField "fieldName" JqNil) , "jqFilterParser test 4" ~: parseJqFilter ".[0].fieldName" ~?= Right (JqIndex 0 (JqField "fieldName" JqNil)) , "jqFilterParser test 5" ~: parseJqFilter ".fieldName[0]" ~?= Right (JqField "fieldName" (JqIndex 0 JqNil)) ] jqFilterParserSpacesTest :: Test jqFilterParserSpacesTest = TestList [ "jqFilterParser spaces test 1" ~: parseJqFilter " . " ~?= Right JqNil , "jqFilterParser spaces test 2" ~: parseJqFilter " . [ 0 ] " ~?= Right (JqIndex 0 JqNil) , "jqFilterParser spaces test 3" ~: parseJqFilter " . fieldName " ~?= Right (JqField "fieldName" JqNil) , "jqFilterParser spaces test 4" ~: parseJqFilter " . [ 0 ] . fieldName " ~?= Right (JqIndex 0 (JqField "fieldName" JqNil)) , "jqFilterParser spaces test 5" ~: parseJqFilter " . fieldName [ 0 ] " ~?= Right (JqField "fieldName" (JqIndex 0 JqNil)) ] -- ************************: jqQueryParserTest :: Test jqQueryParserTest = TestList [ "jqQueryParser test 1" ~: parseJqQuery "[]" ~?= Right (JqQueryArray []) , "jqQueryParser test 2" ~: parseJqQuery "[.hoge,.piyo]" ~?= Right (JqQueryArray [JqQueryFilter (JqField "hoge" JqNil), JqQueryFilter (JqField "piyo" JqNil)]) , "jqQueryParser test 3" ~: parseJqQuery "{\"hoge\":[],\"piyo\":[]}" ~?= Right (JqQueryObject [("hoge", JqQueryArray []), ("piyo", JqQueryArray [])]) ] jqQueryParserSpacesTest :: Test jqQueryParserSpacesTest = TestList [ "jqQueryParser spaces test 1" ~: parseJqQuery " [ ] " ~?= Right (JqQueryArray []) , "jqQueryParser spaces test 2" ~: parseJqQuery " [ . hoge , . piyo ] " ~?= Right (JqQueryArray [JqQueryFilter (JqField "hoge" JqNil), JqQueryFilter (JqField "piyo" JqNil)]) , "jqQueryParser spaces test 3" ~: parseJqQuery "{ \"hoge\" : [ ] , \"piyo\" : [ ] } " ~?= Right (JqQueryObject [("hoge", JqQueryArray []), ("piyo", JqQueryArray [])]) ] -- ***************** applyFilterTest :: Test applyFilterTest = TestList [ "applyFilter test 1" ~: applyFilter (unsafeParseFilter ".") testData ~?= Right testData , "applyFilter test 2" ~: (Just $ applyFilter (unsafeParseFilter ".string-field") testData) ~?= fmap Right (testData^?key "string-field") , "applyFilter test 3" ~: (Just $ applyFilter (unsafeParseFilter ".nested-field.inner-string") testData) ~?= fmap Right (testData ^? key "nested-field" . key "inner-string") , "applyFilter test 4" ~: (Just $ applyFilter (unsafeParseFilter ".nested-field.inner-number") testData) ~?= fmap Right (testData ^? key "nested-field" . key "inner-number") , "applyFilter test 5" ~: (Just $ applyFilter (unsafeParseFilter ".array-field[0]") testData) ~?= fmap Right (testData ^? key "array-field" . nth 0) , "applyFilter test 6" ~: (Just $ applyFilter (unsafeParseFilter ".array-field[1]") testData) ~?= fmap Right (testData ^? key "array-field" . nth 1) , "applyFilter test 7" ~: (Just $ applyFilter (unsafeParseFilter ".array-field[2].object-in-array") testData) ~?= fmap Right (testData ^? key "array-field" . nth 2 . key "object-in-array") ] executeQueryTest :: Test executeQueryTest = TestList -- [ "executeQuery test 1" ~: executeQuery (unsafeParseQuery "{}") testData ~?= Right (Object $ H.fromList []) [ "executeQuery test 1" ~: executeQuery (unsafeParseQuery "{}") testData ~?= Right (Object $ KM.fromList []) , "executeQuery test 2" ~: executeQuery (unsafeParseQuery "{ \"fielda\": . , \"fieldb\": .string-field }") testData ~?= -- Right (Object $ H.fromList [("fielda", testData), ("fieldb", String "string value")]) Right (Object $ KM.fromList [("fielda", testData), ("fieldb", String "string value")]) , "executeQuery test 3" ~: executeQuery (unsafeParseQuery "[ .string-field, .nested-field.inner-string ]") testData ~?= Right (Array $ V.fromList [String "string value", String "inner value"]) ] ----- testData :: Value -- testData = Object $ H.fromList testData = Object $ KM.fromList [ ("string-field", String "string value") -- , ("nested-field", Object $ H.fromList , ("nested-field", Object $ KM.fromList [ ("inner-string", String "inner value") , ("inner-number", Number 100) ] ) , ("array-field", Array $ V.fromList [ String "first field" , String "next field" -- , Object (H.fromList , Object (KM.fromList [ ("object-in-array", String "string value in object-in-array") ] ) ] ) ] unsafeParseFilter :: Text -> JqFilter unsafeParseFilter t = case parseJqFilter t of Right f -> f -- Left s -> error $ "PARSE FAILURE IN A TEST : " ++ unpack s Left s -> error $ "PARSE FAILURE IN A TEST : " ++ s unsafeParseQuery :: Text -> JqQuery unsafeParseQuery t = case parseJqQuery t of Right q -> q -- Left s -> error $ "PARSE FAILURE IN A TEST : " ++ unpack s Left s -> error $ "PARSE FAILURE IN A TEST : " ++ s main :: IO () main = do result <- runTestTT $ (TestList [ jqFilterParserTest , jqFilterParserSpacesTest , jqQueryParserTest , jqQueryParserSpacesTest , applyFilterTest , executeQueryTest ]) print result -- Parser.hs ****************************************** {-# LANGUAGE OverloadedStrings #-} module Data.Hjq.Parser ( JqFilter(..) , parseJqFilter , JqQuery(..) , parseJqQuery ) where import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Data.Void (Void) import qualified Data.Text as T import Data.Char () ------------------------------------------------------------ -- JqFilter 定義 ------------------------------------------------------------ data JqFilter = JqNil | JqField String JqFilter | JqIndex Int JqFilter deriving (Show, Read, Eq) type Parser = Parsec Void String ------------------------------------------------------------ -- JqFilter パーサ ------------------------------------------------------------ parseJqFilter :: T.Text -> Either String JqFilter parseJqFilter s = case parse (sc *> topFilter <* eof) "" (T.unpack s) of Left err -> Left (errorBundlePretty err) Right v -> Right v topFilter :: Parser JqFilter topFilter = schar '.' *> filterRest filterRest :: Parser JqFilter filterRest = try parseIndex <|> try parseField <|> pure JqNil parseField :: Parser JqFilter parseField = do name <- lexeme (some (letterChar <|> schar '-' ) ) rest <- option JqNil (schar '.' *> filterRest <|> parseIndex) return $ JqField name rest parseIndex :: Parser JqFilter parseIndex = do idx <- schar '[' *> lexeme L.decimal <* schar ']' rest <- option JqNil (schar '.' *> filterRest <|> parseField) return $ JqIndex idx rest ------------------------------------------------------------ -- JqQuery 定義 & パーサ ------------------------------------------------------------ data JqQuery = JqQueryObject [(T.Text, JqQuery)] | JqQueryArray [JqQuery] | JqQueryFilter JqFilter deriving (Show, Read, Eq) parseJqQuery :: T.Text -> Either String JqQuery parseJqQuery s = case parse (sc *> jqQueryParser <* eof) "" (T.unpack s) of Left err -> Left (errorBundlePretty err) Right v -> Right v jqQueryParser :: Parser JqQuery jqQueryParser = queryArray <|> queryObject <|> queryFilter queryArray :: Parser JqQuery queryArray = do _ <- schar '[' elems <- jqQueryParser `sepBy` schar ',' _ <- schar ']' return $ JqQueryArray elems queryObject :: Parser JqQuery queryObject = do _ <- schar '{' kvs <- qObj `sepBy` schar ',' _ <- schar '}' return $ JqQueryObject kvs where qObj = do key <- schar '"' *> (T.pack <$> some letterChar) <* schar '"' _ <- schar ':' val <- jqQueryParser return (key, val) queryFilter :: Parser JqQuery queryFilter = JqQueryFilter <$> topFilter ------------------------------------------------------------ -- 共通補助 ------------------------------------------------------------ sc :: Parser () sc = L.space space1 empty empty lexeme :: Parser a -> Parser a lexeme = L.lexeme sc schar :: Char -> Parser Char schar c = lexeme (char c) -- Query.hs ********************************************* {-# LANGUAGE OverloadedStrings #-} module Data.Hjq.Query where import Control.Lens import Control.Monad import Data.Monoid import Data.Hjq.Parser import Data.Aeson import Data.Aeson.Lens -- import Data.Text as T import qualified Data.Vector as V -- import qualified Data.HashMap.Strict as H import qualified Data.Text as T import Data.Aeson.Key (fromText) import qualified Data.Aeson.KeyMap as KM import qualified Data.Aeson.Key as Key applyFilter :: JqFilter -> Value -> Either T.Text Value applyFilter (JqField fieldName n) obj@(Object _) = join $ noteNotFoundError (T.pack fieldName) (fmap (applyFilter n) (obj ^? key (fromText(T.pack fieldName)))) applyFilter (JqIndex index n) array@(Array _) = join $ noteOutOfRangeError index (fmap (applyFilter n) (array ^? nth index)) applyFilter JqNil v = Right v applyFilter f o = Left $ "unexpected pattern : " <> tshow f <> " : " <> tshow o executeQuery :: JqQuery -> Value -> Either T.Text Value executeQuery (JqQueryObject o) v -- = fmap (Object . H.fromList) . sequence . fmap sequence $ fmap (fmap $ flip executeQuery v) o = fmap (Object . KM.fromList . fmap (\(k,v) -> (Key.fromText k, v))) . sequence . fmap sequence $ fmap (fmap $ flip executeQuery v) o executeQuery (JqQueryArray l) v = fmap (Array . V.fromList) . sequence $ fmap (flip executeQuery v) l executeQuery (JqQueryFilter f) v = applyFilter f v noteNotFoundError :: T.Text -> Maybe a -> Either T.Text a noteNotFoundError _ (Just x) = Right x noteNotFoundError s Nothing = Left $ "field name not found" <> s noteOutOfRangeError :: Int -> Maybe a -> Either T.Text a noteOutOfRangeError _ (Just x) = Right x noteOutOfRangeError s Nothing = Left $ "out of range : " <> tshow s tshow :: Show a => a -> T.Text tshow = T.pack . Prelude.show

よくわからないところを確認してみた。

Spec.hs

・applyFilterTestについて

   ^?  指定データを１部取り出したいとき使用(lens)

　nth 2 リストの３番目要素取り出し

   fmap Right (testData^?key "string-field") だと  fmap::(a->b)->f a->f bでみると

　(a->b)がRight　　f aがMaybe Value   f bがJustつまりMaybe(Either e Value)

　これにRightが適用なるようだ

Parser.hs

・queryArrayの　jqQueryParser `sepBy` schar ','　について

　　sepByは中値だが、２引数関数で　schar ','を区切りとして　jqQueryParserでパース

Query.hs

・applyFilter (JqField fieldName n) obj@(Object _)

  = join $ noteNotFoundError (T.pack fieldName) (fmap (applyFilter n) (obj ^? key (fromText(T.pack fieldName))))  について

   obj@(Object _)はObjectとか確認し、その値をobjとして利用可能

　joinはMaybeをはずすため

・executeQuery (JqQueryObject o) v

   = fmap (Object . KM.fromList . fmap (\(k,v) -> (Key.fromText k, v)))

    . sequence　②

    . fmap sequence　①

    $ fmap (fmap $ flip executeQuery v) o　　について        

    左辺の(JqQueryObject o) vは{"name":.name,"age":.age}::[(Text,JqQuery)]

    右辺の fmap $ flip executeQuery v のflipは引数を逆順にして、部分適用を意図した 通りにするために使う。(flip executeQuery v) q == executeQuery q v　

　 fmap (fmap $ flip executeQuery v) は、内側のfmapで( , )への処理を、外側のfmapで上の関数使って[  , , ]への処理を行う。

　　sequenceは①で　Eitherを外に出していく　[(either Text (Text,Value))]

        ②で　Ehter Text　[(Text,Value)]にする

　　　パーシングは、なかなか複雑

Haskell入門 P318

 スペースがある場合のパース

Spec.hs

{-# LANGUAGE OverloadedStrings #-} import Test.HUnit import qualified Data.Text() import Data.Hjq.Parser jqFilterParserTest :: Test jqFilterParserTest = TestList [ "jqFilterParser test 1" ~: parseJqFilter "." ~?= Right JqNil , "jqFilterParser test 2" ~: parseJqFilter ".[0]" ~?= Right (JqIndex 0 JqNil) , "jqFilterParser test 3" ~: parseJqFilter ".fieldName" ~?= Right (JqField "fieldName" JqNil) , "jqFilterParser test 4" ~: parseJqFilter ".[0].fieldName" ~?= Right (JqIndex 0 (JqField "fieldName" JqNil)) , "jqFilterParser test 5" ~: parseJqFilter ".fieldName[0]" ~?= Right (JqField "fieldName" (JqIndex 0 JqNil)) ] jqFilterParserSpacesTest :: Test jqFilterParserSpacesTest = TestList [ "jqFilterParser spaces test 1" ~: parseJqFilter " . " ~?= Right JqNil , "jqFilterParser spaces test 2" ~: parseJqFilter " . [ 0 ] " ~?= Right (JqIndex 0 JqNil) , "jqFilterParser spaces test 3" ~: parseJqFilter " . fieldName " ~?= Right (JqField "fieldName" JqNil) , "jqFilterParser spaces test 4" ~: parseJqFilter " . [ 0 ] . fieldName " ~?= Right (JqIndex 0 (JqField "fieldName" JqNil)) , "jqFilterParser spaces test 5" ~: parseJqFilter " . fieldName [ 0 ] " ~?= Right (JqField "fieldName" (JqIndex 0 JqNil)) ] main :: IO () main = do result <- runTestTT $ (TestList [jqFilterParserTest,jqFilterParserSpacesTest]) print result

Parser.hs

{-# LANGUAGE OverloadedStrings #-} module Data.Hjq.Parser ( JqFilter(..) , parseJqFilter ) where import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Data.Void (Void) import qualified Data.Text as T -- JqFilter の定義 data JqFilter = JqNil | JqField String JqFilter | JqIndex Int JqFilter deriving (Show, Eq) -- Megaparsec のパーサ型 type Parser = Parsec Void String -- Text を受け取り String に変換してパース parseJqFilter :: T.Text -> Either String JqFilter parseJqFilter s = --case parse topFilter "" (T.unpack s) of case parse (sc *> topFilter <* eof) "" (T.unpack s) of Left err -> Left (errorBundlePretty err) Right v -> Right v -- トップレベルのパーサ topFilter :: Parser JqFilter topFilter = do _ <- schar '.' -- 最初のドットを消費 filterRest -- ドットの後の要素を判断 filterRest :: Parser JqFilter filterRest = try parseIndex <|> try parseField <|> pure JqNil -- フィールド名パーサ parseField :: Parser JqFilter parseField = do --name <- some letterChar name <- lexeme (some letterChar) -- ★ 空白をスキップする rest <- option JqNil (schar '.' *> filterRest <|> parseIndex) return $ JqField name rest -- 配列インデックスパーサ parseIndex :: Parser JqFilter parseIndex = do --idx <- schar '[' *> L.decimal <* schar ']' idx <- schar '[' *> lexeme L.decimal <* schar ']' -- ★ rest <- option JqNil (schar '.' *> filterRest <|> parseField) return $ JqIndex idx rest -- 空白を処理するヘルパー sc :: Parser () sc = L.space space1 empty empty -- トークンラッパ lexeme :: Parser a -> Parser a lexeme = L.lexeme sc symbol :: String -> Parser String symbol = L.symbol sc -- 文字1個版（いわゆる schar） schar :: Char -> Parser Char schar c = lexeme (char c)

本ではscharが標準である？のかもしれないが、新しいライブラリにはないようで、作る必要があった。ChatGPTから作ってもらう。ついでに、以下のような説明もしてもらうが、 Megaparsec自体なじみがないので、難しい感じが。理解できるようになるためには、もう少し時間がかかりそう。

1. sc :: Parser ()

sc = L.space space1 empty empty

目的：空白やコメントをまとめてスキップする

L.space は Megaparsec が提供する空白スキップ用パーサ。

引数：

space1 → 1個以上の空白文字（' ', '\t', '\n'）をスキップ

empty → 行コメントの始まり（今回は使わないので空）

empty → ブロックコメントの始まり（今回は使わないので空）

つまり、この sc は「空白があるところを自由に無視する」パーサです。

2. lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
目的：トークンを読んだあと、自動で空白をスキップする
使い方：
lexeme L.decimal    -- 数字を読み取ったあと、空白を消費
lexeme (some letterChar)  -- 識別子を読み取ったあと、空白を消費
イメージ：
入力: "123   "
lexeme L.decimal → 123 を返す、空白も消費ない場合は、後ろの空白が残り、パースが失敗しやすくなります。

3. symbol :: String -> Parser String
symbol = L.symbol sc
目的：記号（キーワードや演算子）を読んだあと空白をスキップ
例：
symbol "."  -- ドットを読み取り、空白も消費     symbol "["  -- 左ブラケットを読み取り、空白も消費      内部的には lexeme (string s) と同じような働きです。

4. schar :: Char -> Parser Char
schar c = lexeme (char c)
目的：単一文字のトークンを読み取り、空白をスキップ
文字 . や [ ] の後ろに空白があっても問題なくパースできる
例：
schar '.'  -- "." と後ろの空白をまとめて消費      schar '['  -- "[" と後ろの空白をまとめて消費

Haskell入門 P316 修正コード

 P316のコードが動作しなかったので、ChatGPTから同等のものに書き直してもらったのがこちら。新しいライブラリMegaparsecを使うといいらしい。

Parser.hs

{-# LANGUAGE OverloadedStrings #-} module Data.Hjq.Parser ( JqFilter(..) , parseJqFilter ) where import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Data.Void (Void) import qualified Data.Text as T -- JqFilter の定義 data JqFilter = JqNil | JqField String JqFilter | JqIndex Int JqFilter deriving (Show, Eq) -- Megaparsec のパーサ型 type Parser = Parsec Void String -- Text を受け取り String に変換してパース parseJqFilter :: T.Text -> Either String JqFilter parseJqFilter s = case parse topFilter "" (T.unpack s) of Left err -> Left (errorBundlePretty err) Right v -> Right v -- トップレベルのパーサ topFilter :: Parser JqFilter topFilter = do _ <- char '.' -- 最初のドットを消費 filterRest -- ドットの後の要素を判断 filterRest :: Parser JqFilter filterRest = try parseIndex <|> try parseField <|> pure JqNil -- フィールド名パーサ parseField :: Parser JqFilter parseField = do name <- some letterChar rest <- option JqNil (char '.' *> filterRest <|> parseIndex) return $ JqField name rest -- 配列インデックスパーサ parseIndex :: Parser JqFilter parseIndex = do idx <- char '[' *> L.decimal <* char ']' rest <- option JqNil (char '.' *> filterRest <|> parseField) return $ JqIndex idx rest

・type Parser =Parsec Void String     :Voidがエラーの型（ない）　Stringが入力の型
　　　Parser 　　a　　　　 =　　　Parsec Void String  a
　限られた使い方　aが結果　　　　　Parsecのほうがカスタマイズしやすいといえる
・try paraseIndex <|>   try parseField  <|> pure JqNil    で<|>は左が失敗したら右ためす
　　　tryは　失敗しても入力を消費せず次を代わりにためす　（入力を巻き戻す）
・some letterChar     :  some １回以上繰り返し　　letterChar　a~zA~Zのパース
・option JqNil  (char '.' *> filterRest <|>  parseField)
      option::  a -> Parser a -> Parser a    
         ディフォルト値->試すパーサ->失敗したら ディフォルトaを返す
      char '.' *> filterRest    :  .を消費し、filterRest返す
       ここではtry不要。すでにfilterRestの中でtryは終えているので

Haskell入門 P316

 このへんのパーサ扱ったところはかなりややこしくなっている。
結局、コードが古くてうまく動作せず、別のライブラリを使うことになった。

でも、いちおう、古いほうも、コードをいろいろ確認してみた。
・showParserResult $ parse (jqFilterParser <* endOfInput) s `feed` ""は
showParserResult $ (parse (jqFilterParser <* endOfInput) s) `feed` ""と同じ意味
<* endOfInput　該当しないところはパースせず　`feed` ""はパース停止の決まり文句のようなものらしい

・fmap pack $ many1 (letter <|> char '-' <|>..... digit())について
many1　は  letter <|> char '-' <|> ... <|> digit は 1文字分のパーサー
many1 (...) はこれを 1回以上繰り返して成功した結果をリスト [Char] にまとめる
fmap pack によって [Char] → Text に変換  
        letter :: Parser Char なので   many1 letter :: Parser [Char] になります。
箱（Parser）はそのままで　中身 [Char] が Text に変わる

・JqIndex ＜＄＞　パース１　＜＊＞　バース２　の意味について復習
＜＄＞で最初に部分適用の関数ができて、その関数のまだ未適用な部分に＜＊＞を順次適用していくしくみ
　パーサの場合、関数がつぎつぎと、無限に適用できる引数があるようなもの。その場合は、つねに、部分適用な関数のままでJqIndexが残ることになるといえそう。再帰状態になるのかも。

Haskell入門 P315 パーサの作成

 本のコードのままではだめで、けっこう厳密さが要求された。バージョンの違いか？

・型のスコープとインポートは明示的に
・Text と String は別物    (T.pack ".")で　Textに
・コンストラクタもエクスポートリストで見えるようにする     (..)など利用
・stack.yaml / package.yaml の依存関係はビルド対象ごとに確認(ライブラリも指定）

といった注意も必要なことがわかる。

ちなみに修正したものは

Spec.hs
import Test.HUnit import System.Exit (exitFailure, exitSuccess) import Data.Hjq.Parser (JqFilter(..)) import Data.Hjq (parseJqFilter) import qualified Data.Text as T main :: IO () main = do counts <- runTestTT $ TestList [ jqFilterParserTest ] if errors counts + failures counts == 0 then exitSuccess else exitFailure jqFilterParserTest :: Test jqFilterParserTest = TestList ["jqFilterParser test 1" ~: parseJqFilter (T.pack ".") ~?= Right JqNil ]
Parser.hs
module Data.Hjq.Parser ( JqFilter(..) ) where import qualified Data.Text as T data JqFilter = JqField T.Text JqFilter | JqIndex Int JqFilter | JqNil deriving (Show,Read,Eq)
Hjq.hs
module Data.Hjq where import qualified Data.Text as T import Data.Hjq.Parser (JqFilter(..)) parseJqFilter :: T.Text -> Either String JqFilter parseJqFilter _ = Right JqNil
package.yaml
library: source-dirs: src dependencies: - base >= 4.7 && < 5 - text >= 2.1.2 executables: hjq-exe: dependencies: - hjq - text >= 2.1.2 tests: hjq-test: dependencies: - hjq - HUnit - text >= 2.1.2

Haskell入門 P314 HUnitによる自動テスト

 テストファーストの考え方をとっているようで、最初にテストの方法がでていた。
ただ、本の内容はバージョンが古くそのままでは動かなかった。
・Test suite not yet implementedとでるので
　　package.yamlにtest:hjq-test:dependencies:のところに - HUnitを追加
　　Spec.hs　の先頭にimport Test.HUnit　追加
・文字エンコードでエラーがでるので
　　Dosプロンプトのショートカットに　cmd /k "chcp 65001 &&  cd　パス"のように、事前にエンコード切り替えをいれる
・runTestTTの型が新しいバージョンでは　返り値が IO Countsというものらしいので
　以下のようなコードにするらしい。

import Test.HUnit
import System.Exit (exitFailure, exitSuccess)
main :: IO ()
main = do
    counts <- runTestTT $ "Test1" ~: 1 + 1 ~?= 2
    if errors counts + failures counts == 0
        then exitSuccess
        else exitFailure

これで、ようやく、うまく動作した。

Haskell入門P286

以下のコードの目的は、子スレッドのエラーがメインスレッドに影響しないようにしたいため、隔離しているようです。

actionIO ::  IO a -> IO a
actionIO  action = do
 mv <- newEmptyMVar :: IO (MVar (Either SomeException a))
 _tid <- forkIO $ do
  result <- try acttion
  putMVar mv result
 result <- takeMVar mv
 case result of
  Left e -> throwIO e
  Right r -> return 

1. actionIO :: IO a -> IO a

IO aのアクションを引数にとり、結果もIO aとして返す関数です。引数のactionを別スレッドで実行し、その結果を取得します。

2. mv <- newEmptyMVar :: IO (MVar (Either SomeException a))

新しい空のMVarを作成します。MVarはスレッド間で値のやり取りができる同期変数です。

型は MVar (Either SomeException a) としています。Either SomeException aは、「例外が起きたか」あるいは「正常に値が得られたか」を表すために使います。

3. _tid <- forkIO $ do ...

forkIOで新しい軽量スレッドを作り、その中でactionを実行します。

forkIOはスレッドIDを返しますが、このコードでは使わないので_tidとして無視しています。

4. result <- try action

tryは、例外が発生する可能性があるIOアクションを安全に実行し、成功時はRight a　例外発生時はLeft SomeExceptionの形で結果を返します。

5. putMVar mv result

mv（空のMVar）に結果を格納します。これでメインスレッドはこの結果を待つことができます。

6. result <- takeMVar mv

メインスレッドで、mvに格納されるまで待ちます。forkIOの中の処理が終わりputMVarが呼ばれるまでブロックされます。

Haskell入門 P285 MVarによるスレッド間の通信

 ChatGPTもlevel5になって、さらにバージョンアップした感じです。

本を読んでも、なかなか理解しにくかったところも、ChatGPTにコードを解説してもらうとすぐに理解できたので、質問者のレベルに合わせて説明できる能力に驚いています。

import Control.Concurrent main :: IO () main = do m <- newEmptyMVar -- スレッド生成 forkIO $ do tid <- myThreadId putStrLn $ show tid ++ ": doing ... heavy ... task ..." threadDelay 2000000 putMVar m () takeMVar m putStrLn "Done"

・m <- newEmptyMVar newEmptyMVarで空のMVarを作成  これはスレッド間の通知用の「信号」として使う予定

 ・forkIOで新しい軽量スレッドを作成。

  この新しいスレッドの中で、myThreadIdでスレッドIDを取得し、コンソールに表示。

  ・putMVar m ()で空のMVarに通知（単なる空のタプル () を入れているだけ）を送る。

  ・メインスレッドはtakeMVar mで、MVarに値が入るのを待つ（ブロックされる）。

  子スレッドが2秒後にputMVarで通知すると、この待機が解除される。       

  ・メインスレッドは、子スレッドが終わったことをMVar経由で待機している。

  　子スレッドは、重たい処理の後にMVarに通知し、メインスレッドに処理完了を知らせる。

 ※　putMVar m ()　は、普通は　MVar aにaを入れる（例えばMVar IntにIntを入れるように）。今は()を入れているが、これはCでいえばVoid　scalaでいえば、Unitみたいなもの。