Хаскелл API для доступа к базе данных SQLite


У меня есть база данных SQLite, и я пытаюсь сделать веб-API для этого. Я пишу это в Haskell, и через scotty в качестве сервера. Я шаблонный сайт от скоти стартера, а затем начал делать API существует. Я полный новичок в Haskell (это мой самый первый проект), поэтому я уверен, здесь много чего я не делаю правильно. Есть, вероятно, много возможностей для рефакторинга. Этот файл, так же как и остальные части проекта, могут также быть найдены здесь. Любые предложения будут высоко ценится!

{-# 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


207
3
задан 28 февраля 2018 в 07:02 Источник Поделиться
Комментарии
2 ответа

Я сосредоточусь на первой детали я заметил, в основном String аргумент в обоих db и port. Только "prod" или "dev" действительные значения. Однако String имеет гораздо больше значений, которые являются допустимыми Strings, например, "Example" и "Hello, World". Но это не действует средах баз данных.

Поэтому мы должны использовать тип, чтобы убедиться, что нам не нужно, чтобы проверить, есть ли у нас действительное среде под рукой:

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

Сейчас db и port может быть написано и без нас беспокоясь о спортивных окружение строк:

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

Если мы позволяем -fwarn-incomplete-patterns, С GHC будет даже сказать нам, когда мы забыли обработать БД среды, чтобы мы могли добавить позже:

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

Нам нужен только один дополнительная функция, чтобы использовать наши DBEnvironment:

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

Наш main только слегка меняется:

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

Можно добавить правильное сообщение об ошибке, но что осталось в качестве упражнения. Обратите внимание, что если у нас есть env в этот момент, мы знаем, что это также является допустимым. Это большая победа по сравнению с предыдущей ситуацией, когда нам пришлось проверить String действует в каждой функции.


Кроме этого, есть некоторые случаи, когда вы используете :: String где они не нужны, например getByID conn (bookID::String). getByID берет String в качестве второго аргумента, так что пока типа подпись :: String это не неправильно, это лишнее.

2
ответ дан 1 марта 2018 в 04:03 Источник Поделиться

processSql можно собрать из библиотеки функций.

Чтобы сократить дублирование кода, включите детали, которые отличаются в параметрах функции можно реализовать. Вещи вы будете делать здесь может быть написано с точки зрения нескольких модулей.

Попробуйте встроенного все, что использован только один раз.

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

1
ответ дан 3 марта 2018 в 02:03 Источник Поделиться