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 )