[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