I have a SQLite database, and I'm trying to make a web API for it. I've been writing it in Haskell, and usingscotty as the server. I templated out the website fromthe 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 whereimport Control.Monad.Trans.Class (lift)import Data.List (intersperse)import Data.Map (fromList)import Data.Monoid ((<>))import Database.HDBCimport Database.HDBC.Sqlite3import 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 declarationsimport Data.Convertible.Basedb :: String -> Stringdb 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 -> Intport 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 stmtgetIDsByAuthor :: (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 stmtgetFullText :: 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 stmtgetByID :: (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 stmtsqlToText :: 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)] -> StringtextToJson maybePairList = case maybePairList of Nothing -> "" Just pairList -> do let myMap = fromList pairList toJSON myMap--processSql :: Maybe [(String, SqlValue)] -> Data.Aeson.Types.Internal.ValueprocessSql sqlPairList = textToJson $ filterOutFields $ sqlToText sqlPairListmain :: 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
2 Answers2
I'll focus on the first detaill I've noticed, mainly theString argument in bothdb andport. Only"prod" or"dev" are valid values. However,String has many more values that are validStrings, 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 namesNowdb andport can be written without us having to worry aobut wrong environment strings:
db :: DBEnvironment -> Stringdb environment = case environment of DBProduction -> "/mnt/vol/pg-text-7.db" DBDevelopment -> "/home/jon/Code/gitenberg-scrape/pg-text-7.db"port :: String -> Intport environment = case environment of DBProduction -> 80 DBDevelopment -> 8000If 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 ourDBEnvironment:
parseEnvironment :: String -> Maybe DBEnvironmentparseEnvironment s = case s of "prod" -> Just DBProduction "dev" -> Just DBDevelopment _ -> NothingOurmain 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 thatif we have anenv 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 theString 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 aString as second argument, so while the type signature:: String is not wrong, it's superfluous.
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
- \$\begingroup\$This is awesome, thanks. Although I still need to learn what things like
>=>are doing.\$\endgroup\$Jonathan– Jonathan2018-03-04 14:37:30 +00:00CommentedMar 4, 2018 at 14:37
You mustlog in to answer this question.
Explore related questions
See similar questions with these tags.