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 )