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

• Jonathan: This is awesome, thanks. Although I still need to learn what things like >=> are doing.