[Haskell-beginners] sqlite+json: code improvement request
jjinkou syoujyo
jjinkou2 at yahoo.fr
Mon Sep 12 17:52:17 CEST 2011
Hello,
i'm trying to implement this code which works but I would like to have advices to refactor this code to be more functionnal.
This code receives an http request such as get?tab=urds,json={...}, converts the string json to a json structure. Then it translates it to an sqlite3 requests and sends back a json structure.
since i will have several tables (urds, labos ... an so on ) i don't believe this code is optimal. there's a bunch of "case ..." that i really dislike.
Though i know that i may try use ReadT monad, i don't really know how to use it with HDBCerrorhandler.
here is the code:
thank you for your help.
================
import Network.CGI
import Database.HDBC
import Database.HDBC.Sqlite3
import Data.Maybe (fromJust)
import Library
import Text.JSON
import Control.Applicative
data UrdTyp = UrdVal {
urdID::String,
urd::String,
urdlaboID::String
} deriving (Eq,Show)
data LaboTyp = LaboVal {
laboID::String,
labo::String
} deriving (Eq,Show)
instance JSON UrdTyp where
showJSON urds = makeObj
[("urdID", showJSON $ urdID urds)
,("urd", showJSON $ urd urds)
,("laboID", showJSON $ urdlaboID urds)]
readJSON urds = do obj <- readJSON urds
UrdVal <$> valFromObj "urdID" obj
<*> valFromObj "urd" obj
<*> valFromObj "laboID" obj
instance JSON LaboTyp where
showJSON labos = makeObj
[("laboID", showJSON $ laboID labos)
,("labo", showJSON $ labo labos)]
readJSON labos = do obj <- readJSON labos
LaboVal <$> valFromObj "laboID" obj
<*> valFromObj "labo" obj
sql2UrdVal::[(String,SqlValue)]->Maybe UrdTyp
sql2UrdVal = toUrdVal . map (\(x,y)-> (x,fromSql y::String))
where
toUrdVal obj= UrdVal <$> lookup "UrdID" obj
<*> lookup "Urd" obj
<*> lookup "LaboID" obj
sql2LaboVal::[(String,SqlValue)]->Maybe LaboTyp
sql2LaboVal = toLaboVal . map (\(x,y)-> (x,fromSql y::String))
where
toLaboVal obj= LaboVal <$> lookup "LaboID" obj
<*> lookup "Labo" obj
sqlReadAll :: String ->IO [[(String,SqlValue)]]
sqlReadAll table = do
handle <- connectSqlite3 "fm.db"
stmt <- prepare handle $ "SELECT * FROM " ++ table
execute stmt []
entryRows <- fetchAllRowsAL' stmt
disconnect handle
return entryRows
sqlReadOne:: String -> String -> Int -> IO [[(String,SqlValue)]]
sqlReadOne table column eid = do
handle <- connectSqlite3 "fm.db"
stmt <- prepare handle $ "SELECT * FROM "
++ table ++ " where "
++ column ++" = ?"
execute stmt [toSql eid]
entryRows <- fetchAllRowsAL' stmt
disconnect handle
return entryRows
queryAll:: CGI CGIResult
queryAll = do
Just table <- getInput "tab"
entryRows <- liftIO $sqlReadAll table
case table of
"urds" -> do
let sqlUrds = map sql2UrdVal entryRows
let listUrds=map (encode.showJSON.fromJust) sqlUrds
let toStr=foldr (\a b -> a++","++b) [] listUrds
setHeader "Content-type" "application/x-javascript"
output $ "{\"list\":"
++ "[" ++ toStr ++ "]"
++ "}"
"labos" -> do
let sqlLabos = map sql2LaboVal entryRows
let listLabos=map (encode.showJSON.fromJust) sqlLabos
let toStr=foldr (\a b -> a++","++b) [] listLabos
setHeader "Content-type" "application/x-javascript"
output $ "{\"list\":"
++ "[" ++ toStr ++ "]"
++ "}"
queryOne:: CGI CGIResult
queryOne = do
jsonString <- getInput "json"
Just table <- getInput "tab"
case table of
"urds" -> do
let (Ok j) = (decode.fromJust) jsonString::Result UrdTyp
let idjson = (read.urdID) j ::Int
entryRows <- liftIO $sqlReadOne "urds" "urdID" idjson
let sqlUrds = map sql2UrdVal entryRows
let val=head.map (encode.showJSON.fromJust) $sqlUrds
setHeader "Content-type" "application/x-javascript"
output $"{\"data\":"++ val ++"}"
"labos" -> do
let (Ok j) = (decode.fromJust) jsonString::Result LaboTyp
let idjson = (read.laboID) j ::Int
entryRows <- liftIO $sqlReadOne "labos" "laboID" idjson
let sqlLabos = map sql2LaboVal entryRows
let val=head.map (encode.showJSON.fromJust) $sqlLabos
setHeader "Content-type" "application/x-javascript"
output $"{\"data\":"++ val ++"}"
addEntrySql :: CGI CGIResult
addEntrySql = do
jsonString<- getInput "json"
Just table <- getInput "tab"
case table of
"urds" -> do
let (Ok j) = (decode.fromJust) jsonString::Result UrdTyp
dbh <- liftIO $ connectSqlite3 "fm.db"
adEJson <-liftIO $ addUrd dbh j
liftIO $ commit dbh
liftIO $ disconnect dbh
setHeader "Content-type" "application/x-javascript"
output $ "{\"entry\": " ++ "\"added\""
++",\n\"data\": "++ encode adEJson ++"}"
"labos" -> do
let (Ok j) = (decode.fromJust) jsonString::Result LaboTyp
dbh <- liftIO $ connectSqlite3 "fm.db"
adEJson <-liftIO $ addLabo dbh j
liftIO $ commit dbh
liftIO $ disconnect dbh
setHeader "Content-type" "application/x-javascript"
output $ "{\"entry\": " ++ "\"added\""
++",\n\"data\": " ++ encode adEJson ++"}"
addUrd :: (IConnection conn) => conn -> UrdTyp -> IO UrdTyp
addUrd dbh urdJs =
handleSql errorHandler $
do
run dbh "insert into urds (urd,LaboID) values (?,?)" $
map toSql [urd urdJs, urdlaboID urdJs]
r <- quickQuery' dbh "select urdID from urds where urd=?"
[toSql (urd urdJs)]
case r of
[[x]] -> return urdJs {urdID= fromSql x}
y -> fail $ "addentry: unexpected result: " ++ show y
where errorHandler e =
do fail $ "problem addentry: "++ show e
addLabo :: (IConnection conn) => conn -> LaboTyp -> IO LaboTyp
addLabo dbh laboJs =
handleSql errorHandler $
do
run dbh "insert into labos (labo) values (?)" $
map toSql [labo laboJs]
r <- quickQuery' dbh "select laboID from labos where labo=?"
[toSql (labo laboJs)]
case r of
[[x]] -> return laboJs {laboID= fromSql x}
y -> fail $ "addentry: unexpected result: " ++ show y
where errorHandler e =
do fail $ "problem addentry: "++ show e
updateEntrySql :: CGI CGIResult
updateEntrySql = do
jsonString<- getInput "json"
Just table <- getInput "tab"
case table of
"urds" -> do
let (Ok j) = (decode.fromJust) jsonString::Result UrdTyp
let entryId = urdID j
dbh <- liftIO $ connectSqlite3 "fm.db"
liftIO $ updateUrd dbh j entryId
liftIO $ commit dbh
liftIO $ disconnect dbh
setHeader "Content-type" "application/x-javascript"
output $ "{\"entry\": " ++ "\"modified\"" ++"}"
"labos" -> do
let (Ok j) = (decode.fromJust) jsonString::Result LaboTyp
let entryId = laboID j
dbh <- liftIO $ connectSqlite3 "fm.db"
liftIO $ updateLabo dbh j entryId
liftIO $ commit dbh
liftIO $ disconnect dbh
setHeader "Content-type" "application/x-javascript"
output $ "{\"entry\": " ++ "\"modified\"" ++"}"
updateUrd :: (IConnection conn) => conn -> UrdTyp -> String -> IO ()
updateUrd dbh urdJs entryId =
handleSql errorHandler $
do
r <- quickQuery' dbh "select urdID from urds where urdID=?"
[toSql entryId]
case r of
[[x]] -> run dbh "UPDATE urds SET urd=?, laboID=? WHERE urdID=?"
(map toSql [urd urdJs, urdlaboID urdJs, entryId])
>> return ()
y -> fail $ "updateUrd: no such urdID : " ++ show y
where errorHandler e =
do fail $ "problem updateUrd: "++ show e
updateLabo :: (IConnection conn) => conn -> LaboTyp -> String -> IO ()
updateLabo dbh laboJs entryId =
handleSql errorHandler $
do
r <- quickQuery' dbh "select laboID from labos where laboID=?"
[toSql entryId]
case r of
[[x]] -> run dbh "UPDATE labos SET labo=? WHERE laboID=?"
(map toSql [labo laboJs, entryId])
>> return ()
y -> fail $ "updateLabo: no such laboID : " ++ show y
where errorHandler e =
do fail $ "problem updatelabo: "++ show e
removeEntrySql :: CGI CGIResult
removeEntrySql = do
jsonString<- getInput "json"
Just table <- getInput "tab"
case table of
"urds" -> do
let (Ok j) = (decode.fromJust) jsonString::Result UrdTyp
dbh <- liftIO $ connectSqlite3 "fm.db"
liftIO $ removeUrd dbh (read(urdID j)::Int)
liftIO $ commit dbh
liftIO $ disconnect dbh
setHeader "Content-type" "application/x-javascript"
output $ "{\"entry\": " ++ "\"deleted\""
++",\n\"EntryId\": "++ show (urdID j)
++"}"
"labos" -> do
let (Ok j) = (decode.fromJust) jsonString::Result LaboTyp
dbh <- liftIO $ connectSqlite3 "fm.db"
liftIO $ removeLabo dbh (read(laboID j)::Int)
liftIO $ commit dbh
liftIO $ disconnect dbh
setHeader "Content-type" "application/x-javascript"
output $ "{\"entry\": " ++ "\"deleted\""
++",\n\"EntryId\": "++ show (laboID j)
++"}"
removeUrd :: (IConnection conn) => conn -> Int -> IO ()
removeUrd dbh entryId =
handleSql errorHandler $
do
r <- quickQuery' dbh "select urdID from urds where urdID=?"
[toSql entryId]
case r of
[[x]] -> run dbh "DELETE FROM urds WHERE urdID=?"
[toSql (entryId)]
>> return ()
y -> fail $ "removeUrd: no such urdID : " ++ show y
where errorHandler e =
do fail $ "problem removeUrd: "++ show e
removeLabo :: (IConnection conn) => conn -> Int -> IO ()
removeLabo dbh entryId =
handleSql errorHandler $
do
r <- quickQuery' dbh "select LaboID from labos where laboID=?"
[toSql entryId]
case r of
[[x]] -> run dbh "DELETE FROM labos WHERE laboID=?"
[toSql (entryId)]
>> return ()
y -> fail $ "removeLabo: no such laboID : " ++ show y
where errorHandler e =
do fail $ "problem removeLabo: "++ show e
queryCommand :: CGI CGIResult
queryCommand = do
commandString <- getInput "command"
case (fromJust commandString) of
"Get" -> queryOne
"GetAll" -> queryAll
"AddEntry" -> addEntrySql
"Modify" -> updateEntrySql
"Remove" -> removeEntrySql
_ -> do
setHeader "Content-type" "application/x-javascript"
output $ "{\"command\":\"rien compris du tout\"}"
main = runCGI (handleErrors queryCommand )
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://www.haskell.org/pipermail/beginners/attachments/20110912/e5350a41/attachment-0001.htm>
More information about the Beginners
mailing list