Myu: 8月 2025

2025年8月31日日曜日

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

※追記：アパッチ転送で注意が必要なのは、/の転送は最後にしないとだめということ。ルートの後に、転送の設定をしてもそれは、無視されるようです。順序が大事なようです。

2025年8月30日土曜日

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

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

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

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

・Main.hsについて
　

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

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

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

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

2025年8月25日月曜日

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内のモナド計算なので不要

2025年8月24日日曜日

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

ここも、分かりにくいところがあり、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]となります。

2025年8月22日金曜日

Haskell入門 P354 各種操作の実装

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は、安全性が求められるのである程度使える設定データは制限したい、そんな感じだろうか。

2025年8月21日木曜日

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で既習)

2025年8月18日月曜日

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)]にする

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

2025年8月16日土曜日

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

-- 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が残ることになるといえそう。再帰状態になるのかも。

2025年8月13日水曜日

Haskell入門 P315 パーサの作成

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

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

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

ちなみに修正したものは

Spec.hs

Parser.hs

Hjq.hs

package.yaml

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

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

2025年8月10日日曜日

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が呼ばれるまでブロックされます。

2025年8月9日土曜日

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

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

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

・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みたいなもの。

登録: 投稿 (Atom)