Haskell API for accessing a SQLite database

Question

I have a SQLite database, and I'm trying to make a web API for it. I've been writing it in Haskell, and using scotty as the server. I templated out the website from the Scotty Starter Kit, and then started making the API there. I'm a complete Haskell beginner (this is my very first project), so I'm sure there's a lot here I'm not doing right. There are probably lots of opportunities for refactoring. This file, as well as the rest of the project, can also be found here. Any suggestions would be much appreciated!

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}

module Main where

import Control.Monad.Trans.Class (lift)
import Data.List (intersperse)
import Data.Map (fromList)
import Data.Monoid ((<>))
import Database.HDBC
import Database.HDBC.Sqlite3
import Data.Aeson (toJSON)
import Controllers.Home (home, docs, login)
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
import Network.Wai.Middleware.Static        (addBase, noDots,
                                             staticPolicy, (>->))
import System.Environment (getEnv)
import Web.Scotty

-- Needed for type declarations
import Data.Convertible.Base

db :: String -> String
db environment = case environment of
  "prod" -> "/mnt/vol/pg-text-7.db" 
  "dev" -> "/home/jon/Code/gitenberg-scrape/pg-text-7.db"
  _ -> error "Environment must be one of 'prod' (production) or 'dev' (development)."

port :: String -> Int
port environment = case environment of
  "prod" -> 80
  "dev" -> 8000
  _ -> error "Environment must be one of 'prod' (production) or 'dev' (development)."

getByAuthor :: (Data.Convertible.Base.Convertible String SqlValue, IConnection conn) => conn -> String -> IO [[(String, SqlValue)]]
getByAuthor conn person = do
  stmt <- prepare conn "select * from meta where author like ?"
  _ <- execute stmt [toSql person]
  fetchAllRowsAL stmt

getIDsByAuthor :: (Data.Convertible.Base.Convertible String SqlValue, IConnection conn) => conn -> String -> IO [[SqlValue]]
getIDsByAuthor conn person = do
  stmt <- prepare conn "select id from meta where author like ?"
  _ <- execute stmt [toSql person]
  fetchAllRows stmt

getFullText :: IConnection conn => conn -> [SqlValue] -> IO [[(String, SqlValue)]]
getFullText conn ids = do
  let query = "select id, text from text where id in (" ++ intersperse ',' ('?' <$ ids) ++ ")"
  stmt <- prepare conn query
  _ <- execute stmt ids
  fetchAllRowsAL stmt

getByID :: (Convertible String SqlValue, IConnection conn) => conn -> String -> IO (Maybe [(String, SqlValue)])
getByID conn bookID = do
  stmt <- prepare conn "select * from meta where id = ?"
  _ <- execute stmt [toSql bookID]
  fetchRowAL stmt

sqlToText :: Maybe [(String, SqlValue)] -> Maybe [(String, String)]
sqlToText maybeSqlPairList = case maybeSqlPairList of
  Nothing -> Nothing
  Just sqlPairList -> Just $ map getVal sqlPairList where
    getVal (a, val) = case val of SqlNull -> (a, "NULL")
                                  _ -> (a, fromSql val :: String)

filterOutFields :: Maybe [(String, String)] -> Maybe [(String, String)]
filterOutFields maybeSqlPairList = case maybeSqlPairList of
  Nothing -> Nothing
  Just sqlPairList -> Just $ filter allowed sqlPairList where
    allowed (key, _) = take 3 key `notElem` ["am_", "gr_"]

-- textToJson :: Maybe [(String, String)] -> String
textToJson maybePairList = case maybePairList of
  Nothing -> ""
  Just pairList -> do
    let myMap = fromList pairList
    toJSON myMap

--processSql :: Maybe [(String, SqlValue)] -> Data.Aeson.Types.Internal.Value
processSql sqlPairList = textToJson $ filterOutFields $ sqlToText sqlPairList

main :: IO ()
main = do
  putStrLn "Starting server..."
  env <- getEnv "ENV"
  let portNumber = port env
      dbPath = db env
  conn <- connectSqlite3 dbPath
  scotty portNumber $ do
    get "/api/hello/:name" $ do
      name <- param "name"
      text ("hello " <> name <> "!")
    get "/api/id/:id" $ do
      bookID <- param "id"
      sql <- lift $ getByID conn (bookID::String)
      json $ processSql sql
    get "/api/id/:id/fulltext" $ do
      bookID <- param "id"
      sql <- lift $ getFullText conn [toSql (bookID::String)]
      json $ map (processSql . Just) sql
    get "/api/author/:author" $ do
      author <- param "author"
      sql <- lift $ getByAuthor conn (author::String)
      json $ map (processSql . Just) sql
    get "/api/author/:author/fulltext" $ do
      author <- param "author"
      ids <- lift $ getIDsByAuthor conn (author::String)
      sql <- lift $ getFullText conn (map head ids)
      json $ map (processSql . Just) sql
    middleware $ staticPolicy (noDots >-> addBase "static/images") -- for favicon.ico
    middleware logStdoutDev
    home >> docs >> login

Answer 1

I'll focus on the first detaill I've noticed, mainly the String argument in both db and port. Only "prod" or "dev" are valid values. However, String has many more values that are valid Strings, e.g. "Example" and "Hello, World". But those aren't valid database environments.

Therefore, we should use a type to make sure that we don't need to check whether we have a valid environment at hand:

data DBEnvironment = DBProduction
                   | DBDevelopment
                   deriving (Eq, Show)
-- feel free to shorten those names

Now db and port can be written without us having to worry aobut wrong environment strings:

db :: DBEnvironment -> String
db environment = case environment of
  DBProduction  -> "/mnt/vol/pg-text-7.db" 
  DBDevelopment -> "/home/jon/Code/gitenberg-scrape/pg-text-7.db"

port :: String -> Int
port environment = case environment of
  DBProduction  -> 80
  DBDevelopment -> 8000

If we enable -fwarn-incomplete-patterns, GHC will even tell us when we forgot to handle a DB environment that we might add later:

data DBEnvironment = DBProduction
                   | DBDevelopment
                   | DBStaging  -- added later, -fwarn-incomplete-patterns warns us
                   deriving (Eq, Show)

We only need a single additional function to use our DBEnvironment:

parseEnvironment :: String -> Maybe DBEnvironment
parseEnvironment s = case s of
  "prod" -> Just DBProduction  
  "dev"  -> Just DBDevelopment 
  _      -> Nothing

Our main only changes slightly:

main :: IO ()
main = do
  putStrLn "Starting server..."
  Just env <- parseEnvironment <$> getEnv "ENV"
  let portNumber = port env
      dbPath = db env
  ...

You could add a proper error message, but that's left as an exercise. Note that if we have an env at that point, we know that it's also a valid one. That's a big win compared to the previous situation where we had to check whether the String was valid in every function.

---

Other than that, there are some instances where you use :: String where they're not necessary, e.g. getByID conn (bookID::String). getByID takes a String as second argument, so while the type signature :: String is not wrong, it's superfluous.

Answer 2

processSql can be assembled from library functions.

To reduce code duplication, turn the parts that differ into the parameters of a function you implement once. The things you happen to be doing here can be written in terms of a few modules.

Try to inline everything that's used only once.

wrap name suffix adapter wrapped = get ("/api/" ++ name ++ "/:" ++ name ++ suffix) $ do
  p <- param name
  sql <- lift (wrapped p)
  json $ (\processSql -> adapter processSql sql)
    $ toJson . fmap (fromMaybe "Null" . fromSql) . fromList
    . filter (\(key, _) -> take 3 key `notElem` ["am_", "gr_"])

(<&>) = flip (<$>)

main :: IO ()
main = do
  putStrLn "Starting server..."
  (db, port) <- getEnv "ENV" <&> \case
    "prod" -> ("/mnt/vol/pg-text-7.db", 80)
    "dev" -> ("/home/jon/Code/gitenberg-scrape/pg-text-7.db", 8000)
    _ -> error "Environment must be one of 'prod' (production) or 'dev' (development)."
  run <- connectSqlite3 db <&> \conn query fetch args -> do
    stmt <- prepare conn $ "select " ++ query
    execute stmt args
    fetch stmt
  let run1 query fetch arg = run query fetch [toSql (arg :: String)]
  scotty port $ do
    get "/api/hello/:name" $ do
      name <- param "name"
      text ("hello " <> name <> "!")
    wrap "id"     ""   (maybe "") $ run1 "* from meta where id = ?" fetchRowAL
    wrap "id"     "/fulltext" map $ run1 "id, text from text where id = ?" fetchAllRowsAL
    wrap "author" ""          map $ run1 "* from meta where author like ?" fetchAllRowsAL
    wrap "author" "/fulltext" map $ run1 "id from meta where author like ?" fetchAllRows
      >=> \ids -> run
        ("id, text from text where id in (" ++ intersperse ',' ('?' <$ ids) ++ ")")
        fetchAllRowsAL (map head ids)
    middleware $ staticPolicy (noDots >-> addBase "static/images") -- for favicon.ico
    middleware logStdoutDev
    home >> docs >> login