<html><body><div style="color:#000; background-color:#fff; font-family:times new roman, new york, times, serif;font-size:12pt"><div>Hello, <br></div><div><br></div><div>i'm trying to implement this code which works but I would like to have advices to refactor this code to be more functionnal. <br></div><div><br></div><div>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. <br></div><div><br></div><div>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.<br></div><div><br>Though i know that i may try use ReadT monad, i don't really know how to use it with HDBCerrorhandler. <br></div><div><br></div><div>here is the code: <br></div><div><br></div><div>thank you for your help.
<br></div><div>================</div><div><br></div><div><br></div><div>import Network.CGI <br>import Database.HDBC <br>import Database.HDBC.Sqlite3 <br>import Data.Maybe (fromJust)<br>import Library<br>import Text.JSON<br>import Control.Applicative<br><br><br>data UrdTyp = UrdVal {<br> urdID::String,<br> urd::String,<br> urdlaboID::String<br>} deriving (Eq,Show)<br><br>data LaboTyp = LaboVal {<br> laboID::String,<br> labo::String<br>} deriving (Eq,Show) <br><br>instance JSON UrdTyp where<br> showJSON urds = makeObj <br> [("urdID", showJSON $ urdID
urds)<br> ,("urd", showJSON $ urd urds)<br> ,("laboID", showJSON $ urdlaboID urds)]<br> readJSON urds = do obj <- readJSON urds<br> UrdVal <$> valFromObj "urdID" obj<br> <*> valFromObj "urd" obj<br> <*>
valFromObj "laboID" obj<br> <br>instance JSON LaboTyp where<br> showJSON labos = makeObj <br> [("laboID", showJSON $ laboID labos)<br> ,("labo", showJSON $ labo labos)]<br> readJSON labos = do obj <- readJSON labos<br> LaboVal <$> valFromObj "laboID"
obj<br> <*> valFromObj "labo" obj<br> <br> <br>sql2UrdVal::[(String,SqlValue)]->Maybe UrdTyp<br>sql2UrdVal = toUrdVal . map (\(x,y)-> (x,fromSql y::String))<br> where <br> toUrdVal obj= UrdVal <$> lookup "UrdID" obj
<br> <*> lookup "Urd" obj<br> <*> lookup "LaboID" obj<br><br>sql2LaboVal::[(String,SqlValue)]->Maybe LaboTyp<br>sql2LaboVal = toLaboVal . map (\(x,y)-> (x,fromSql y::String))<br> where <br> toLaboVal obj= LaboVal <$> lookup "LaboID" obj <br> <*> lookup "Labo" obj<br><br>sqlReadAll :: String ->IO [[(String,SqlValue)]]<br>sqlReadAll
table = do <br> handle <- connectSqlite3 "fm.db" <br> stmt <- prepare handle $ "SELECT * FROM " ++ table <br> execute stmt []<br> entryRows <- fetchAllRowsAL' stmt <br> disconnect handle<br> return entryRows<br><br> <br>sqlReadOne:: String -> String -> Int -> IO [[(String,SqlValue)]]<br>sqlReadOne table column eid = do <br> handle <- connectSqlite3 "fm.db" <br> stmt <- prepare handle $ "SELECT * FROM "<br> ++ table ++ " where
"<br> ++ column ++" = ?" <br> execute stmt [toSql eid]<br> entryRows <- fetchAllRowsAL' stmt <br> disconnect handle<br> return entryRows<br><br>queryAll:: CGI CGIResult<br>queryAll = do<br> Just table <- getInput "tab"<br> entryRows <- liftIO $sqlReadAll table<br> case table of <br> "urds" -> do <br> let sqlUrds = map sql2UrdVal entryRows <br> let listUrds=map (encode.showJSON.fromJust)
sqlUrds<br> let toStr=foldr (\a b -> a++","++b) [] listUrds<br> setHeader "Content-type" "application/x-javascript"<br> output $ "{\"list\":" <br> ++ "[" ++ toStr ++ "]" <br> ++ "}"<br> "labos" -> do <br> let sqlLabos = map
sql2LaboVal entryRows <br> let listLabos=map (encode.showJSON.fromJust) sqlLabos<br> let toStr=foldr (\a b -> a++","++b) [] listLabos<br> setHeader "Content-type" "application/x-javascript"<br> output $ "{\"list\":" <br> ++ "[" ++ toStr ++ "]" <br> ++
"}"<br><br><br>queryOne:: CGI CGIResult<br>queryOne = do<br> jsonString <- getInput "json"<br> Just table <- getInput "tab"<br> case table of <br> "urds" -> do <br> let (Ok j) = (decode.fromJust) jsonString::Result UrdTyp<br> let idjson = (read.urdID) j ::Int<br> entryRows <- liftIO $sqlReadOne "urds" "urdID" idjson<br> let sqlUrds = map sql2UrdVal entryRows <br> let val=head.map (encode.showJSON.fromJust)
$sqlUrds<br> setHeader "Content-type" "application/x-javascript"<br> output $"{\"data\":"++ val ++"}"<br> "labos" -> do <br> let (Ok j) = (decode.fromJust) jsonString::Result LaboTyp<br> let idjson = (read.laboID) j ::Int<br> entryRows <- liftIO $sqlReadOne "labos" "laboID" idjson<br> let sqlLabos = map sql2LaboVal entryRows <br> let val=head.map (encode.showJSON.fromJust)
$sqlLabos<br> setHeader "Content-type" "application/x-javascript"<br> output $"{\"data\":"++ val ++"}"<br><br><br>addEntrySql :: CGI CGIResult<br>addEntrySql = do<br> jsonString<- getInput "json"<br> Just table <- getInput "tab"<br> case table of <br> "urds" -> do <br> let (Ok j) = (decode.fromJust) jsonString::Result UrdTyp<br> dbh <- liftIO $ connectSqlite3 "fm.db" <br> adEJson <-liftIO $ addUrd dbh j
<br> liftIO $ commit dbh<br> liftIO $ disconnect dbh<br> setHeader "Content-type" "application/x-javascript"<br> output $ "{\"entry\": " ++ "\"added\""<br> ++",\n\"data\": "++ encode adEJson ++"}"<br> "labos" -> do <br> let (Ok j) = (decode.fromJust) jsonString::Result
LaboTyp<br> dbh <- liftIO $ connectSqlite3 "fm.db" <br> adEJson <-liftIO $ addLabo dbh j <br> liftIO $ commit dbh<br> liftIO $ disconnect dbh<br> setHeader "Content-type" "application/x-javascript"<br> output $ "{\"entry\": " ++ "\"added\""<br> ++",\n\"data\": " ++
encode adEJson ++"}"<br><br>addUrd :: (IConnection conn) => conn -> UrdTyp -> IO UrdTyp<br>addUrd dbh urdJs =<br> handleSql errorHandler $ <br> do<br> run dbh "insert into urds (urd,LaboID) values (?,?)" $ <br> map toSql [urd urdJs, urdlaboID urdJs] <br> r <- quickQuery' dbh "select urdID from urds where urd=?" <br> [toSql (urd urdJs)] <br> case r of <br> [[x]] -> return
urdJs {urdID= fromSql x}<br> y -> fail $ "addentry: unexpected result: " ++ show y<br> where errorHandler e =<br> do fail $ "problem addentry: "++ show e<br><br>addLabo :: (IConnection conn) => conn -> LaboTyp -> IO LaboTyp<br>addLabo dbh laboJs =<br> handleSql errorHandler $ <br> do<br> run dbh "insert into labos (labo) values (?)" $ <br> map toSql [labo laboJs] <br> r <- quickQuery' dbh "select laboID from labos where
labo=?" <br> [toSql (labo laboJs)] <br> case r of <br> [[x]] -> return laboJs {laboID= fromSql x}<br> y -> fail $ "addentry: unexpected result: " ++ show y<br> where errorHandler e =<br> do fail $ "problem addentry: "++ show e<br><br>updateEntrySql :: CGI CGIResult<br>updateEntrySql = do<br> jsonString<- getInput "json"<br> Just table <- getInput "tab"<br> case table of
<br> "urds" -> do <br> let (Ok j) = (decode.fromJust) jsonString::Result UrdTyp<br> let entryId = urdID j<br> dbh <- liftIO $ connectSqlite3 "fm.db" <br> liftIO $ updateUrd dbh j entryId <br> liftIO $ commit dbh<br> liftIO $ disconnect dbh<br> setHeader "Content-type"
"application/x-javascript"<br> output $ "{\"entry\": " ++ "\"modified\"" ++"}"<br><br> "labos" -> do <br> let (Ok j) = (decode.fromJust) jsonString::Result LaboTyp<br> let entryId = laboID j<br> dbh <- liftIO $ connectSqlite3 "fm.db" <br> liftIO $ updateLabo dbh j entryId <br> liftIO $ commit
dbh<br> liftIO $ disconnect dbh<br> setHeader "Content-type" "application/x-javascript"<br> output $ "{\"entry\": " ++ "\"modified\"" ++"}"<br><br>updateUrd :: (IConnection conn) => conn -> UrdTyp -> String -> IO ()<br>updateUrd dbh urdJs entryId = <br> handleSql errorHandler $ <br> do <br> r <- quickQuery' dbh "select urdID from urds where urdID=?" <br> [toSql entryId] <br> case r of <br> [[x]] -> run dbh
"UPDATE urds SET urd=?, laboID=? WHERE urdID=?" <br> (map toSql [urd urdJs, urdlaboID urdJs, entryId])<br> >> return ()<br> y -> fail $ "updateUrd: no such urdID : " ++ show y<br> where errorHandler e =<br> do fail $ "problem updateUrd: "++ show e<br><br>updateLabo :: (IConnection conn) => conn -> LaboTyp -> String -> IO ()<br>updateLabo dbh laboJs entryId = <br> handleSql errorHandler $ <br> do <br> r <- quickQuery' dbh "select laboID from
labos where laboID=?" <br> [toSql entryId] <br> case r of <br> [[x]] -> run dbh "UPDATE labos SET labo=? WHERE laboID=?" <br> (map toSql [labo laboJs, entryId])<br> >> return ()<br> y -> fail $ "updateLabo: no such laboID : " ++ show y<br> where errorHandler e =<br> do fail $ "problem updatelabo: "++ show e<br><br>removeEntrySql :: CGI
CGIResult<br>removeEntrySql = do<br> jsonString<- getInput "json"<br> Just table <- getInput "tab"<br> case table of <br> "urds" -> do <br> let (Ok j) = (decode.fromJust) jsonString::Result UrdTyp<br> dbh <- liftIO $ connectSqlite3 "fm.db" <br> liftIO $ removeUrd dbh (read(urdID j)::Int) <br> liftIO $ commit dbh<br> liftIO $ disconnect
dbh<br> setHeader "Content-type" "application/x-javascript"<br> output $ "{\"entry\": " ++ "\"deleted\""<br> ++",\n\"EntryId\": "++ show (urdID j)<br> ++"}"<br><br> "labos" -> do <br> let (Ok j) = (decode.fromJust) jsonString::Result LaboTyp<br> dbh <- liftIO $
connectSqlite3 "fm.db" <br> liftIO $ removeLabo dbh (read(laboID j)::Int) <br> liftIO $ commit dbh<br> liftIO $ disconnect dbh<br> setHeader "Content-type" "application/x-javascript"<br> output $ "{\"entry\": " ++ "\"deleted\""<br> ++",\n\"EntryId\": "++ show (laboID
j)<br> ++"}"<br><br>removeUrd :: (IConnection conn) => conn -> Int -> IO ()<br>removeUrd dbh entryId =<br> handleSql errorHandler $ <br> do <br> r <- quickQuery' dbh "select urdID from urds where urdID=?" <br> [toSql entryId] <br> case r of <br> [[x]] -> run dbh "DELETE FROM urds WHERE urdID=?"<br> [toSql
(entryId)]<br> >> return ()<br> y -> fail $ "removeUrd: no such urdID : " ++ show y<br> where errorHandler e =<br> do fail $ "problem removeUrd: "++ show e <br><br><br>removeLabo :: (IConnection conn) => conn -> Int -> IO ()<br>removeLabo dbh entryId =<br> handleSql errorHandler $ <br> do <br> r <- quickQuery' dbh "select LaboID from labos where laboID=?" <br> [toSql entryId] <br> case r of <br>
[[x]] -> run dbh "DELETE FROM labos WHERE laboID=?"<br> [toSql (entryId)]<br> >> return ()<br> y -> fail $ "removeLabo: no such laboID : " ++ show y<br> where errorHandler e =<br> do fail $ "problem removeLabo: "++ show e <br><br>queryCommand :: CGI CGIResult <br>queryCommand = do<br> commandString <- getInput "command"<br> case (fromJust commandString) of<br> "Get"
-> queryOne<br> "GetAll" -> queryAll <br> "AddEntry" -> addEntrySql <br> "Modify" -> updateEntrySql<br> "Remove" -> removeEntrySql<br> _ -> do<br> setHeader "Content-type" "application/x-javascript"<br> output $ "{\"command\":\"rien compris du tout\"}" <br><br><br>main = runCGI (handleErrors queryCommand )<br><br></div></div></body></html>