{-#LANGUAGE NoImplicitPrelude #-}
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE TypeFamilies #-}
{-#LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE FlexibleContexts #-}
{-#LANGUAGE LambdaCase #-}
module Web.Sprinkles.Backends.Loader.SqlLoader
( sqlLoader
)
where
import Web.Sprinkles.Prelude
import Web.Sprinkles.Backends.Data
( BackendData (..)
, BackendMeta (..)
, BackendSource (..)
, Verification (..)
, Items (..)
, reduceItems
, rawFromLBS
)
import qualified Database.HDBC as HDBC
import qualified Web.Sprinkles.Databases as DB
import Web.Sprinkles.Databases (DSN (..), sqlDriverFromID)
import Web.Sprinkles.Logger (LogLevel (..))
import Data.Aeson as JSON
import Data.Aeson.TH as JSON
import Data.Yaml as YAML
import Web.Sprinkles.Backends.Loader.Type
import Data.List.Extra (takeEnd)
sqlLoader :: DSN -> DB.ResultSetMode -> [(Text, [Text])] -> Loader
sqlLoader dsn mode queries writeLog _ fetchMode fetchOrder = do
resultSets <- DB.withConnection dsn $ \conn -> do
HDBC.withTransaction conn $ \conn -> do
forM queries $ \(query, params) -> do
writeLog Debug $
"SQL: QUERY: " <> tshow query <>
" ON " <> DB.dsnToText dsn <>
" WITH: " <> tshow params
stmt <- HDBC.prepare conn (unpack query)
HDBC.execute stmt (map HDBC.toSql params)
HDBC.fetchAllRowsMap stmt
return $ mergeResultSets resultSets
where
mergeResultSets :: [[Map String HDBC.SqlValue]] -> [BackendSource]
mergeResultSets [] = []
mergeResultSets rawRows = case mode of
DB.ResultsMerge ->
map mapRow . mconcat $ rawRows
DB.ResultsNth i ->
map mapRow . mconcat . drop i . take 1 $ rawRows
DB.ResultsLast ->
map mapRow . mconcat . takeEnd 1 $ rawRows
mapRow :: Map String HDBC.SqlValue -> BackendSource
mapRow row =
let json = JSON.encode (fmap (HDBC.fromSql :: HDBC.SqlValue -> Maybe Text) row)
name = maybe "SQL" HDBC.fromSql $
lookup "name" row <|>
lookup "title" row <|>
(headMay . fmap snd . mapToList $ row)
meta = BackendMeta
{ bmMimeType = "application/json"
, bmMTime = Nothing
, bmName = name
, bmPath = "SQL"
, bmSize = Just . fromIntegral $ length json
}
in BackendSource meta (rawFromLBS json) Trusted