スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

[Haskell]HDBCを使ってみる

Haskellを勉強中です。DBへの接続を練習がてら書いてみました。
果たしてこんな書き方で良いのか・・・

# vim pw.hs

module Main where

import System.Environment (getArgs)
import System.Directory (removeFile, getHomeDirectory)
import Data.Map (lookup)
import Database.HDBC
import Database.HDBC.Sqlite3

db = ".pw.db"

main = do
args <- getArgs
dir <- getHomeDirectory
conn <- connectSqlite3 (dir ++ "/" ++ db)
case args of
("new":_) -> createDB conn
("add":xs) -> addAccount conn xs
("edit":xs) -> editAccount conn xs
("remove":xs) -> removeAccount conn xs
("list":xs) -> showAccountList conn xs
("show":xs) -> showAccountDetail conn xs
("addtag":accountid:xs) -> addTag conn accountid xs
("removetag":accountid:xs) -> removeTag conn accountid xs
("drop":_) -> removeFile (dir ++ "/" ++ db)
_ -> putStrLn "no command"
commit conn
disconnect conn
return ()

createDB conn = do
run conn ("create table accounts ("
++ " id integer primary key"
++ ", userid varchar(50) not null"
++ ", password varchar(50) not null"
++ ")") []
run conn ("create table tags ("
++ " id integer primary key"
++ ", accountid integer not null"
++ ", tag varchar(100) not null"
++ ")") []
return ()

addAccount conn (userid:password:tags) = do
stmt <- prepare conn "insert into accounts (userid, password) values (?, ?)"
execute stmt [toSql userid, toSql password]
accountid <- lastInsertRowid conn "accounts"
addTag conn accountid tags
return ()

editAccount conn (accountid:userid:password:xs) = do
stmt <- prepare conn "update accounts set userid = ?, password = ? where id = ?"
execute stmt [toSql userid, toSql password, toSql accountid]
return ()

removeAccount conn (accountid:_) = do
stmt <- prepare conn "delete from accounts where id = ?"
execute stmt [toSql accountid]
stmt <- prepare conn "delete from tags where accountid = ?"
execute stmt [toSql accountid]
return ()

showAccountList conn xs = do
let sql = "select * from accounts"
stmt <- case xs of
[] -> do
stmt <- prepare conn (sql ++ " order by id")
execute stmt []
return stmt
[tag] -> do
stmt <- prepare conn (sql
++ " where id in (select accountid from tags where tag like ?)"
++ " order by id")
execute stmt [toSql ("%" ++ tag ++ "%")]
return stmt
l <- fetchAllRowsMap stmt
showAccountList' l
putStr "\n"

showAccountList' [] = putStr "no accounts"
showAccountList' [r] = putStr (strval "id" r ++ " :: " ++ strval "userid" r
++ " - " ++ strval "password" r)
showAccountList' (r:rs) = showAccountList' [r] >> putStr "\n" >> showAccountList' rs

showAccountDetail conn (accountid:xs) = do
stmt <- prepare conn "select * from accounts where id = ?"
execute stmt [toSql accountid]
l <- fetchAllRowsMap stmt
showAccountList' l
stmt <- prepare conn "select * from tags where accountid = ?"
execute stmt [toSql accountid]
l <- fetchAllRowsMap stmt
putStr " -- ["
showTags' l
putStrLn "]"
where showTags' [] = putStr "no tags"
showTags' [r] = putStr (strval "tag" r)
showTags' (r:rs) = showTags' [r] >> putStr ", " >> showTags' rs

addTag conn accountid tags = do
stmt <- prepare conn "insert into tags (accountid, tag) values (?, ?)"
addTag' stmt accountid tags
return ()
where addTag' _ _ [] = return ()
addTag' stmt accountid (tag:ts) = do
execute stmt [toSql accountid, toSql tag]
addTag' stmt accountid ts
return ()

removeTag conn accountid (tag:ts) = do
stmt <- prepare conn "delete from tags where accountid = ? and tag = ?"
execute stmt [toSql accountid, toSql tag]
return ()

lastInsertRowid conn table = do
r <- quickQuery' conn ("select last_insert_rowid() from " ++ table ++ " limit 1") []
return (fromSql (head (head r)) :: String)


------------------------------------
intval k row = case Data.Map.lookup k row of
Nothing -> 0
(Just x) -> (fromSql x)::Int
strval k row = case Data.Map.lookup k row of
Nothing -> ""
(Just x) -> (fromSql x)::String

コンパイルはこんな感じでした。
# ghc pw.hs -o pw --make

コメントの投稿

非公開コメント

プロフィール

jou4

Author:jou4
FC2ブログへようこそ!

最新記事
最新コメント
最新トラックバック
月別アーカイブ
カテゴリ
検索フォーム
RSSリンクの表示
リンク
ブロとも申請フォーム

この人とブロともになる

QRコード
QRコード
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。