A Haskell newbie's guide to Snap, Part 3

This is a followup to Part 1 and Part 2.  Those posts covered the basics of using Snap and Heist, and their APIs for accessing data from the HTTP request and from the splice instance.  This post will show how to access SQL data with the HDBC package (in this case, we'll use PostgreSQL).  Along the way, I hope to give a better picture of how all the pieces fit together (though I'd welcome comments from experienced Snappers on how the code might be improved).  

Grabbing Data from SQL

The design for our simple cheese app specified a form to enter the cheese name, then another form to edit the rest of the data.  The previous post explained the name form, now we'll look at the second form.  This form will have text inputs for the cheese's name, country, price, and amount of stock.  If the cheese exists in our database, we want to edit its current values; else we want to create a new entry.  So if our requests's URI is /cheese_template?name=Epoisses, then we want the name input initialized to Epoisses, and the other three inputs initialized to the result of the query SELECT [column] FROM cheese WHERE name='Epoisses'.  The splice uri_text_input that we defined last time will work for the name input.  We will define a splice sql_text_input for the other three inputs.   We'll use the splice like

 

   <sql_text_input table="cheese" key="name" value="uri:name"   

                  column="country" label="Country:"/>

and we want that to produce 

 

   Country: <input type='text' value='France' name='Country' />

Again we'll use our decode function (found in Part 2) to pull out values from either the splice instance or the URI, and some XmlHtml. functions to build up the HTML result:

  sqlTextInput :: Splice Application
  sqlTextInput = do
    node <- getParamNode
    req <- lift getRequest
    let column = decode node req "column"
    let key    = decode node req "key"
    let value  = decode node req "value"
    let table  = decode node req "table"
    let label  = decode node req "label"
    let query  = bldQueryWhereEq column table key $ addQuote value
    ival <- liftIO $ runQuery query
    let element = X.Element { X.elementTag = "input",
                              X.elementAttrs = [("type","text"),
                                                ("value",DT.pack ival),
                                                ("name",DT.pack column)], 
                              X.elementChildren = [] }
    return $ (X.TextNode $ DT.pack $ label ++ ": ") : [element]

There's a new addQuote function that quotes the data value (if it's not quoted, SQL will take it as a column name), and the functions runQuery and bldQueryWhereEq that handle the SQL work.  We have bldQueryWhereEq return a Maybe String; if any of the input Strings is empty, the result will be an invalid query.  Rather than returning an invalid query string to the caller, let's return Nothing.  Additionally, a modular design will use a reusable function bldQueryBasic, which builds the base query string SELECT [column] FROM [table].  To make effective use of this design, we will need to lift the (++) operator up into the Maybe monad.  We'll name it (+++).  The resulting code looks like:

  bldQueryWhereEq :: String -> String -> String -> String -> Maybe String
  bldQueryWhereEq col tab key val = 
      bldQueryBasic col tab +++ Just " WHERE " +++ notMT key  
                            +++ Just " = " +++ notMT val
  bldQueryBasic :: String -> String -> Maybe String
  bldQueryBasic col table = 
  Just "SELECT " +++ notMT col +++ Just " FROM " +++ notMT table
  (+++) :: Maybe String -> Maybe String -> Maybe String
  (+++) = liftM2 (++)
  notMT :: String -> Maybe String
  notMT [] = Nothing
  notMT x = Just x

Now we can define runQuery. We will make use of the quickQuery' function from the HDBC package (we want a strict function or we would just use quickQuery).  quickQuery' will return a list of type SqlValue; fromSql will convert the values to strings.

  import HDBC
  import HDBC.PostgresSQL 
  runQuery :: Maybe String -> IO String
  runQuery Nothing = return ""
  runQuery (Just x) =  do
        conn <- connectPostgreSQL "dbname=test"
        results <- quickQuery' conn x []
        disconnect conn
        return $ (concat . intersperse "," . map fromSql . concat) results

Saving Data To SQL

Now we've got a simple app that meets most of our use cases: it allows the user to create a new cheese or edit an existing one.  The big thing it won't do at this point is save the data.  We'll handle saving data in the splice that builds the text input for our top form (the one with only a single text input for the name).  To do this, we will create a new splice uriTextWithSave that functions as a uriTextInput but with the side effect of saving the POST data to SQL if the query string contains ?_task=save and the 'name' value in the POST data is not null.  The top level structure is

  uriTextWithSave :: Splice Application
  uriTextWithSave = do
       saveCheeseData
       uriTextInput
  saveCheeseData :: Splice Application
  saveCheeseData = do
       req <- lift getRequest
       nada <- liftIO $ maybeSaveCheese req 
       return []
  maybeSaveCheese :: Request -> IO ()
  maybeSaveCheese req = do
       let task = getReqParam req "_task"
           name = getReqParam req "name"
       if (not $ null name) && (task == "save")
       then (saveCheese req)
       else return ()

The actual return value of saveCheeseData is always empty; we only care about the side effects.  Together, these three functions determine if we need to save the data, then pull the Request information from the Splice context and pass it to the saveCheese function.

Next, we will define a utility function that will grab a value from the HTTP data that was POSTed or put into the query string:

  getReqParam :: Request -> ByteString -> String
  getReqParam req attr = 
      byteStrToStr $ head $ fromMaybe [BS.empty] $ rqParam attr req

Now we're ready to write the code that actually performs the SQL action.  If the cheese is already in the database, we want to perform an UPDATE; otherwise we want to INSERT.  Our code will use a couple of utility functions that we'll define later, existsEntry and bldUpdate.

We will use prepared SQL statements in this code to illustrate their use in HDBC.

  cheeseColumns = ["name","country","price","stock"]
  saveCheese :: Request -> IO ()
  saveCheese req = do
      let  name = getReqParam req "name"
      exists <- existsEntry "cheese" "name" name
      if exists
      then updateCheese req
      else insertCheese req
  updateCheese :: Request -> IO ()
  updateCheese req = do
      conn <- connectPostgreSQL "dbname=test"
      let values = map (toSql . getReqParam req) cheeseColumns
          where_clause = "name=" ++ (addQuote $ getReqParam req "name")
          update  = bldUpdate "cheese" (map byteStrToStr cheeseColumns) where_clause
      stmt <- prepare conn update
      execute stmt $ values
      commit conn
      disconnect conn
 
  insertCheese :: Request -> IO ()
  insertCheese req = do
      conn <- connectPostgreSQL "dbname=test"
      stmt <- prepare conn "INSERT INTO cheese VALUES (?, ?, ?, ?)"
    let values = map (toSql . getReqParam req) cheeseColumns
      execute stmt values
      commit conn
      disconnect conn

This code could be made quite a bit more general.  The table name and its columns could be merged into a record and passed in as an argument rather than hardcoded, and the (four) question marks could be build up with replicate $ length columnArray.  See that code here (start at uriTextWithSave).  

Our existsEntry function runs a simple query on the key and value to see if they exist.  If the string of results is empty, then the entry does not exist. 

  existsEntry :: String -> String -> String -> IO Bool
  existsEntry table key value =  do
      results <- runQuery $ bldQueryWhereEq "*" table key $ addQuote value
      if "" == results
      then return False
      else return True

The bldUpdate function builds an update query.  For the cheese table, we want the query to look like UPDATE cheese SET name=?, country=?, price=?, stock=? WHERE name='Epoisses'. 

  bldUpdate :: String -> [String] -> String -> String
  bldUpdate table columns where_clause = 
      "UPDATE " ++ table ++ " SET " ++ update_list ++ " WHERE " ++ where_clause
    where
      updateEntry c = c ++ "=?"
      update_list = if null columns
                    then ""
                    else foldl (\t c -> t ++ ", " ++ updateEntry c)  
                               (updateEntry $ head columns) 
                               (tail columns)

That completes the code to save the new data to SQL.For more information on HDBC, chapter 21 of Real World Haskell gives a nice overview.  The hackage entry for HDBC has the full details on the API.