{-#LANGUAGE NoImplicitPrelude #-} {-#LANGUAGE OverloadedStrings #-} {-#LANGUAGE TypeFamilies #-} {-#LANGUAGE MultiParamTypeClasses #-} {-#LANGUAGE FlexibleInstances #-} {-#LANGUAGE FlexibleContexts #-} {-#LANGUAGE LambdaCase #-} -- | SQL backend loader module Web.Sprinkles.Backends.Loader.SqlLoader ( sqlLoader ) where import ClassyPrelude import Web.Sprinkles.Backends.Data ( BackendData (..) , BackendMeta (..) , BackendSource (..) , 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 sqlLoader :: DSN -> Text -> [Text] -> Loader sqlLoader dsn query params writeLog _ fetchMode fetchOrder = do rows <- DB.withConnection dsn $ \conn -> do HDBC.withTransaction conn $ \conn -> 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 $ map mapRow rows where mapRow :: Map String HDBC.SqlValue -> BackendSource mapRow row = let json = JSON.encode (fmap (HDBC.fromSql :: HDBC.SqlValue -> 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)