diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2017 Anton Ekblad + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/selda-postgresql.cabal b/selda-postgresql.cabal new file mode 100644 --- /dev/null +++ b/selda-postgresql.cabal @@ -0,0 +1,42 @@ +name: selda-postgresql +version: 0.1.0.0 +synopsis: PostgreSQL backend for the Selda database EDSL. +description: PostgreSQL backend for the Selda database EDSL. + Requires the PostgreSQL @libpq@ development libraries to be + installed. +homepage: https://github.com/valderman/selda +license: MIT +license-file: LICENSE +author: Anton Ekblad +maintainer: anton@ekblad.cc +category: Database +build-type: Simple +cabal-version: >=1.10 + +flag haste + default: False + description: Package is being installed for Haste. + +library + exposed-modules: + Database.Selda.PostgreSQL + other-extensions: + GADTs + RecordWildCards + OverloadedStrings + CPP + build-depends: + base >=4.8 && <5 + , exceptions >=0.8 && <0.9 + , selda >=0.1 && <0.2 + , text >=1.0 && <1.3 + if !flag(haste) + build-depends: + bytestring >=0.9 && <0.11 + , postgresql-libpq >=0.9 && <0.10 + hs-source-dirs: + src + default-language: + Haskell2010 + ghc-options: + -Wall diff --git a/src/Database/Selda/PostgreSQL.hs b/src/Database/Selda/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Selda/PostgreSQL.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards, GADTs, CPP #-} +-- | PostgreSQL backend for Selda. +module Database.Selda.PostgreSQL + ( PGConnectInfo (..), PGConnectException (..) + , withPostgreSQL, on, auth + ) where +import Data.Monoid +import qualified Data.Text as T +import Data.Text.Encoding +import Database.Selda.Backend +import Control.Monad.Catch + +#ifndef __HASTE__ +import Database.PostgreSQL.LibPQ hiding (user, pass, db, host) +import qualified Data.ByteString.Char8 as BS +#endif + +-- | The exception thrown when a connection could not be made to the PostgreSQL +-- server. +data PGConnectException = PGConnectException String + deriving Show +instance Exception PGConnectException + +-- | The exception thrown when a query fails. +data PGQueryException = PGQueryException String + deriving Show +instance Exception PGQueryException + +-- | PostgreSQL connection information. +data PGConnectInfo = PGConnectInfo + { -- | Host to connect to. + pgHost :: T.Text + -- | Port to connect to. + , pgPort :: Int + -- | Name of database to use. + , pgDatabase :: T.Text + -- | Username for authentication, if necessary. + , pgUsername :: Maybe T.Text + -- | Password for authentication, if necessary. + , pgPassword :: Maybe T.Text + } + +-- | Connect to the given database on the given host, on the default PostgreSQL +-- port (5432): +-- +-- > withPostgreSQL ("my_db" `on` "example.com") $ do +-- > ... +on :: T.Text -> T.Text -> PGConnectInfo +on db host = PGConnectInfo + { pgHost = host + , pgPort = 5432 + , pgDatabase = db + , pgUsername = Nothing + , pgPassword = Nothing + } +infixl 7 `on` + +-- | Add the given username and password to the given connection information: +-- +-- > withPostgreSQL ("my_db" `on` "example.com" `auth` ("user", "pass")) $ do +-- > ... +-- +-- For more precise control over the connection options, you should modify +-- the 'PGConnectInfo' directly. +auth :: PGConnectInfo -> (T.Text, T.Text) -> PGConnectInfo +auth ci (user, pass) = ci + { pgUsername = Just user + , pgPassword = Just pass + } +infixl 4 `auth` + +-- | Perform the given computation over a PostgreSQL database. +-- The database connection is guaranteed to be closed when the computation +-- terminates. +withPostgreSQL :: (MonadIO m, MonadThrow m, MonadMask m) + => PGConnectInfo -> SeldaT m a -> m a +#ifdef __HASTE__ +withPostgreSQL _ _ = return $ error "withPostgreSQL called in JS context" +#else +withPostgreSQL ci m = do + conn <- liftIO $ connectdb (pgConnString ci) + st <- liftIO $ status conn + case st of + ConnectionOk -> runSeldaT m (pgBackend conn) `finally` liftIO (finish conn) + nope -> connFailed nope + where + connFailed f = throwM $ PGConnectException $ unwords + [ "unable to connect to postgres server: " ++ show f + ] + +pgBackend :: Connection -> SeldaBackend +pgBackend c = SeldaBackend + { runStmt = \q ps -> right <$> pgQueryRunner c False q ps + , runStmtWithPK = \q ps -> left <$> pgQueryRunner c True q ps + , customColType = pgColType + } + where + left (Left x) = x + left _ = error "impossible" + right (Right x) = x + right _ = error "impossible" + +pgConnString :: PGConnectInfo -> BS.ByteString +pgConnString PGConnectInfo{..} = mconcat + [ "host=", encodeUtf8 pgHost, " " + , "port=", BS.pack (show pgPort), " " + , "dbname=", encodeUtf8 pgDatabase, " " + , case pgUsername of + Just user -> "user=" <> encodeUtf8 user <> " " + _ -> "" + , case pgPassword of + Just pass -> "password=" <> encodeUtf8 pass <> " " + _ -> "" + , "connect_timeout=10", " " + , "client_encoding=UTF8" + ] + +pgQueryRunner :: Connection -> Bool -> T.Text -> [Param] -> IO (Either Int (Int, [[SqlValue]])) +pgQueryRunner c return_lastid q ps = do + mres <- execParams c (encodeUtf8 q') [fromSqlValue p | Param p <- ps] Text + case mres of + Just res -> do + st <- resultStatus res + case st of + BadResponse -> throwM $ PGQueryException "bad response" + FatalError -> throwM $ PGQueryException errmsg + NonfatalError -> throwM $ PGQueryException errmsg + _ | return_lastid -> Left <$> getLastId res + | otherwise ->Right <$> getRows res + Nothing -> error "unable to submit query to server" + where + errmsg = "error executing query `" ++ T.unpack q' ++ "'" + q' | return_lastid = q <> " RETURNING LASTVAL();" + | otherwise = q + + getLastId res = (read . BS.unpack . maybe "" id) <$> getvalue res 0 0 + + getRows res = do + rows <- ntuples res + cols <- nfields res + types <- mapM (ftype res) [0..cols-1] + affected <- cmdTuples res + result <- mapM (getRow res types cols) [0..rows-1] + pure $ case affected of + Just "" -> (0, result) + Just s -> (read $ BS.unpack s, result) + _ -> (0, result) + + getRow res types cols row = do + sequence $ zipWith (getCol res row) [0..cols-1] types + + getCol res row col t = do + mval <- getvalue res row col + case mval of + Just val -> pure $ toSqlValue t val + _ -> pure SqlNull + +-- | Convert the given postgres return value and type to an @SqlValue@. +-- TODO: use binary format instead of text. +toSqlValue :: Oid -> BS.ByteString -> SqlValue +toSqlValue t val + | t == boolType = SqlBool $ readBool val + | t == intType = SqlInt $ read (BS.unpack val) + | t == doubleType = SqlFloat $ read (BS.unpack val) + | t `elem` textish = SqlString (decodeUtf8 val) + | otherwise = error $ "result with unknown type oid: " ++ show t + where + textish = [textType, timestampType, timeType, dateType] + readBool "f" = False + readBool "0" = False + readBool "0.0" = False + readBool "F" = False + readBool _ = True + +-- | Convert a parameter into an postgres parameter triple. +fromSqlValue :: Lit a -> Maybe (Oid, BS.ByteString, Format) +fromSqlValue (LitB b) = Just (boolType, if b then "true" else "false", Text) +fromSqlValue (LitI n) = Just (intType, BS.pack $ show n, Text) +fromSqlValue (LitD f) = Just (doubleType, BS.pack $ show f, Text) +fromSqlValue (LitS s) = Just (textType, encodeUtf8 s, Text) +fromSqlValue (LitTS s) = Just (timestampType, encodeUtf8 s, Text) +fromSqlValue (LitTime s) = Just (timeType, encodeUtf8 s, Text) +fromSqlValue (LitDate s) = Just (dateType, encodeUtf8 s, Text) +fromSqlValue (LitNull) = Nothing +fromSqlValue (LitJust x) = fromSqlValue x + +-- | Custom column types for postgres: auto-incrementing primary keys need to +-- be @BIGSERIAL@, and ints need to be @INT8@. +pgColType :: T.Text -> [ColAttr] -> Maybe T.Text +pgColType "INTEGER" attrs + | AutoIncrement `elem` attrs = + Just "BIGSERIAL PRIMARY KEY NOT NULL" + | otherwise = + Just $ T.unwords ("INT8" : map compileColAttr attrs) +pgColType "DOUBLE" attrs = + Just $ T.unwords ("FLOAT8" : map compileColAttr attrs) +pgColType "DATETIME" attrs = + Just $ T.unwords ("TIMESTAMP" : map compileColAttr attrs) +pgColType _ _ = + Nothing + +-- | OIDs for all types used by Selda. +boolType, intType, textType, doubleType :: Oid +boolType = Oid 16 +intType = Oid 20 +textType = Oid 25 +doubleType = Oid 701 +dateType = Oid 1082 +timeType = Oid 1083 +timestampType = Oid 1114 +#endif