seakale-postgresql (empty) → 0.1.0.0
raw patch · 7 files changed
+452/−0 lines, 7 filesdep +basedep +bytestringdep +freesetup-changed
Dependencies added: base, bytestring, free, mtl, postgresql-libpq, seakale, time
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- seakale-postgresql.cabal +45/−0
- src/Database/Seakale/PostgreSQL.hs +249/−0
- src/Database/Seakale/PostgreSQL/FromRow.hs +81/−0
- src/Database/Seakale/PostgreSQL/ToRow.hs +40/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for seakale-postgresql++## 0.1.0.0 -- 2017-01-31++* First version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Thomas Feron++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Thomas Feron nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ seakale-postgresql.cabal view
@@ -0,0 +1,45 @@+name: seakale-postgresql+version: 0.1.0.0+synopsis: PostgreSQL backend for Seakale+description: This package provides a way to run code written with Seakale with a PostgreSQL database.+license: BSD3+license-file: LICENSE+author: Thomas Feron+maintainer: thomas.feron@redspline.com+category: Database+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++source-repository head+ type: darcs+ location: http://darcs.redspline.com/seakale+ tag: 0.1.0.0++library+ ghc-options: -Wall+ hs-source-dirs: src+ default-language: Haskell2010++ default-extensions: TypeFamilies+ OverloadedStrings+ FlexibleInstances+ MultiParamTypeClasses+ FunctionalDependencies+ ConstraintKinds+ LambdaCase+ RecordWildCards+ OverloadedStrings+ FlexibleContexts++ exposed-modules: Database.Seakale.PostgreSQL+ Database.Seakale.PostgreSQL.FromRow+ Database.Seakale.PostgreSQL.ToRow++ build-depends: base >=4.8 && <4.10+ , seakale+ , postgresql-libpq+ , bytestring+ , mtl+ , free+ , time
+ src/Database/Seakale/PostgreSQL.hs view
@@ -0,0 +1,249 @@+module Database.Seakale.PostgreSQL+ ( Connection+ , ConnectInfo(..)+ , connect+ , connectString+ , disconnect+ , Request+ , RequestT+ , runRequest+ , runRequestT+ , Select+ , SelectT+ , runSelect+ , runSelectT+ , Store+ , StoreT+ , runStore+ , runStoreT+ , HasConnection(..)+ , PSQL(..)+ , SeakaleError(..)+ , T.Query(..) -- prefixed to export EmptyQuery+ , Field(..)+ , Row+ , ColumnInfo(..)+ , QueryData+ , Vector(..)+ , cons, (<:>)+ , nil, (<:|)+ , Zero+ , One+ , Two+ , Three+ , Four+ , Five+ , Six+ , Seven+ , Eight+ , Nine+ , Ten+ ) where++import Control.Monad.Except+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Free++import Data.Maybe+import Data.Monoid+import Data.Word+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BSL++import Database.PostgreSQL.LibPQ hiding (Row, status)++import Database.Seakale.Types+ hiding (runQuery, runExecute, EmptyQuery)+import qualified Database.Seakale.Request.Internal as I+import qualified Database.Seakale.Store.Internal as I+import qualified Database.Seakale.Types as T++data ConnectInfo = ConnectInfo+ { ciHostname :: String+ , ciPort :: Word16+ , ciUsername :: String+ , ciPassword :: String+ , ciDatabase :: String+ }++toConnectionString :: ConnectInfo -> BS.ByteString+toConnectionString ConnectInfo{..} =+ "host=" <> quote ciHostname+ <> " port=" <> BS.pack (show ciPort)+ <> " user=" <> quote ciUsername+ <> " password=" <> quote ciPassword+ <> " dbname=" <> quote ciDatabase++ where+ quote :: String -> BS.ByteString+ quote = ("'" <>) . (<> "'") . escapeQuotes "" . BS.pack++ escapeQuotes :: BS.ByteString -> BS.ByteString -> BS.ByteString+ escapeQuotes _ "" = ""+ escapeQuotes prefix s =+ let (start, end) = fmap (BS.drop 1) $ BS.break (=='\'') s+ in prefix <> start <> escapeQuotes "''" end++connect :: ConnectInfo -> IO Connection+connect = connectString . toConnectionString++connectString :: BS.ByteString -> IO Connection+connectString = connectdb++disconnect :: Connection -> IO ()+disconnect = finish++class Monad m => HasConnection m where+ withConn :: (Connection -> m a) -> m a++instance Monad m => HasConnection (ReaderT Connection m) where+ withConn f = f =<< ask++instance HasConnection m => HasConnection (ExceptT e m) where+ withConn f = do+ eRes <- lift $ withConn $ runExceptT . f+ either throwError return eRes++instance HasConnection m => HasConnection (StateT s m) where+ withConn f = do+ s <- get+ (x, s') <- lift $ withConn $ flip runStateT s . f+ put s'+ return x++type TypeCache = [(Oid, BS.ByteString)]++data PSQL = PSQL++instance Backend PSQL where+ type ColumnType PSQL = BS.ByteString++ type MonadBackend PSQL m = ( HasConnection m+ , MonadState TypeCache m+ , MonadIO m+ )++ runQuery _ = runExceptT . runQuery+ runExecute _ = runExceptT . runExecute++type RequestT = I.RequestT PSQL+type Request = I.Request PSQL++runRequestT :: (HasConnection m, MonadIO m) => RequestT m a+ -> m (Either SeakaleError a)+runRequestT =+ fmap fst . flip runStateT [] . I.runRequestT PSQL . hoistFreeT lift++runRequest :: (HasConnection m, MonadIO m) => Request a+ -> m (Either SeakaleError a)+runRequest = runRequestT . hoistFreeT (return . runIdentity)++type SelectT = I.SelectT PSQL+type Select = I.Select PSQL++runSelectT :: Monad m => SelectT m a -> RequestT m a+runSelectT = I.runSelectT++runSelect :: Select a -> Request a+runSelect = I.runSelect++type StoreT m = I.StoreT PSQL m+type Store = I.Store PSQL++runStoreT :: Monad m => StoreT m a -> RequestT m a+runStoreT = I.runStoreT++runStore :: Store a -> Request a+runStore = I.runStore++runQuery :: MonadBackend PSQL m => BSL.ByteString+ -> ExceptT BS.ByteString m ([ColumnInfo PSQL], [Row PSQL])+runQuery lazyReq = do+ let req = mconcat $ BSL.toChunks lazyReq+ res <- exec' req++ let _until i = takeWhile (/= i) $ iterate (+1) 0+ ncols <- liftIO $ nfields res+ nrows <- liftIO $ ntuples res++ let colIndices = _until ncols+ cols <- forM colIndices $ \col -> do+ name <- liftIO $ fname res col+ oid <- liftIO $ ftype res col+ typ <- resolveType oid+ return ColumnInfo+ { colInfoName = name+ , colInfoType = typ+ }++ rows <- liftIO $ forM (_until nrows) $ \row -> do+ forM colIndices $ \col -> do+ mValue <- getvalue' res row col+ return Field { fieldValue = mValue }++ return (cols, rows)++runExecute :: MonadBackend PSQL m => BSL.ByteString+ -> ExceptT BS.ByteString m Integer+runExecute lazyReq = do+ let req = mconcat $ BSL.toChunks lazyReq+ res <- exec' req++ mBS <- liftIO $ cmdTuples res+ case fmap (reads . BS.unpack) mBS of+ Just ((n,"") : _) -> return n+ _ -> throwError $ "Can't get number of rows affected for " <> req++resolveType :: MonadBackend PSQL m => Oid+ -> ExceptT BS.ByteString m BS.ByteString+resolveType oid = do+ cache <- get+ case lookup oid cache of+ Just n -> return n+ Nothing -> do+ cache' <- getTypes+ put cache'+ case lookup oid cache' of+ Just n -> return n+ Nothing -> throwError $ BS.pack $ "Can't resolve type for " ++ show oid++getTypes :: MonadBackend PSQL m => ExceptT BS.ByteString m TypeCache+getTypes = do+ res <- exec' "SELECT oid, typname FROM pg_type"+ let _until i = takeWhile (/= i) $ iterate (+1) 0+ nrows <- liftIO $ ntuples res++ forM (_until nrows) $ \row -> do+ oidBS <- liftIO $ getvalue' res row 0+ nameBS <- liftIO $ getvalue' res row 1+ case (fmap (reads . BS.unpack) oidBS, nameBS) of+ (Just ((i,"") : _), Just name) ->+ return (Oid (fromInteger i), name)+ _ -> throwError "Can't read types from pg_type"++exec' :: MonadBackend PSQL m => BS.ByteString+ -> ExceptT BS.ByteString m Result+exec' req = do+ res <- withConn $ \conn -> do+ mRes <- liftIO $ exec conn req+ case mRes of+ Nothing -> do+ err <- liftIO $ fromMaybe "Fatal error" <$> errorMessage conn+ throwError err+ Just r -> return r++ let err bs = do+ msg <- liftIO $ fromMaybe bs <$> resultErrorMessage res+ throwError msg+ status <- liftIO $ resultStatus res+ case status of+ EmptyQuery -> err "Empty query"+ CopyIn -> err "COPY not supported"+ CopyOut -> err "COPY not supported"+ BadResponse -> err "Bad response"+ FatalError -> err "Fatal error"+ _ -> return ()++ return res
+ src/Database/Seakale/PostgreSQL/FromRow.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Database.Seakale.PostgreSQL.FromRow+ ( module Database.Seakale.FromRow+ ) where++import Data.Monoid+import Data.Time+import qualified Data.ByteString.Char8 as BS++import Database.Seakale.FromRow+import Database.Seakale.PostgreSQL++instance FromRow PSQL One Bool where+ fromRow = pconsume `pbind` \(_, f) -> case fieldValue f of+ Nothing -> pfail "unexpected NULL"+ Just "t" -> preturn True+ Just "f" -> preturn False+ Just bs -> pfail $ "unreadable boolean: " ++ BS.unpack bs++instance FromRow PSQL One UTCTime where+ fromRow = pconsume `pbind` \(ColumnInfo{..}, Field{..}) ->+ case (colInfoType, fieldValue) of+ ("timestamp", Just bs) ->+ case parseTimeM True defaultTimeLocale "%F %T%Q" (BS.unpack bs) of+ Just t -> preturn t+ Nothing -> pfail $ "invalid time: " ++ BS.unpack bs+ ("timestamptz", Just bs) ->+ case parseTimeM True defaultTimeLocale "%F %T%Q%z"+ (BS.unpack bs ++ "00") of+ Just t -> preturn t+ Nothing -> pfail $ "invalid time: " ++ BS.unpack bs+ (bs, Just _) -> pfail $ "invalid type for time: " ++ BS.unpack bs+ (_, Nothing) -> pfail "unexpected NULL for time"++instance FromRow PSQL One String where+ fromRow = pmap BS.unpack fromRow++instance {-# OVERLAPPABLE #-} FromRow PSQL One a => FromRow PSQL One [a] where+ fromRow = pconsume `pbind` \(col@ColumnInfo{..}, Field{..}) ->+ case (BS.splitAt 1 colInfoType, fieldValue) of+ (("_", typ), Just bs) -> arrayParser (col { colInfoType = typ }) bs+ (_, Just _) -> pfail $ "invalid type for list: " ++ BS.unpack colInfoType+ (_, Nothing) -> pfail "unexpected NULL for list"++-- FIXME: What about \n for example?+arrayParser :: FromRow PSQL One a => ColumnInfo PSQL -> BS.ByteString+ -> RowParser PSQL Zero [a]+arrayParser col = either pfail preturn . go+ where+ go :: FromRow PSQL One a => BS.ByteString -> Either String [a]+ go bs = case BS.splitAt 1 bs of+ ("{", "}") -> return []+ ("{", bs') -> readValues id bs'+ _ -> Left $ "invalid array starting with " ++ show (BS.take 30 bs)++ readValues :: FromRow PSQL One a => ([a] -> [a]) -> BS.ByteString+ -> Either String [a]+ readValues f bs = do+ (valBS, bs') <- readByteString bs+ let mValBS = if valBS == "NULL" then Nothing else Just valBS+ val <- parseRow fromRow PSQL [col] [Field mValBS]+ case BS.splitAt 1 bs' of+ (",", bs'') -> readValues (f . (val :)) bs''+ ("}", "") -> return $! f [val]+ _ -> Left $ "invalid array around " ++ show (BS.take 30 bs')++ readByteString :: BS.ByteString+ -> Either String (BS.ByteString, BS.ByteString)+ readByteString bs = case BS.splitAt 1 bs of+ ("\"", bs') -> readByteString' "" bs'+ _ -> return $ BS.span (\c -> c /= ',' && c /= '}') bs++ readByteString' :: BS.ByteString -> BS.ByteString+ -> Either String (BS.ByteString, BS.ByteString)+ readByteString' acc bs =+ case fmap (BS.splitAt 1) (BS.span (\c -> c /= '"' && c /= '\\') bs) of+ (bs', ("\"", bs'')) -> return (acc <> bs', bs'')+ (bs', ("\\", bs'')) -> let (c, bs''') = BS.splitAt 1 bs''+ in readByteString' (acc <> bs' <> c) bs'''+ (bs', _) -> Left $ "unreadable value around " ++ show (BS.take 30 bs')
+ src/Database/Seakale/PostgreSQL/ToRow.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Seakale.PostgreSQL.ToRow+ ( module Database.Seakale.ToRow+ ) where++import Data.List+import Data.Monoid+import Data.Time+import qualified Data.ByteString.Char8 as BS++import Database.Seakale.ToRow+import Database.Seakale.Types++import Database.Seakale.PostgreSQL++instance ToRow PSQL One Bool where+ toRow _ = \case+ True -> Cons "'t'" Nil+ False -> Cons "'f'" Nil++instance ToRow PSQL One UTCTime where+ toRow backend = toRow backend . formatTime defaultTimeLocale "%F %T%QZ"++instance ToRow PSQL One String where+ toRow backend = toRow backend . BS.pack++instance {-# OVERLAPPABLE #-} ToRow PSQL One a => ToRow PSQL One [a] where+ toRow backend =+ singleton . ("'{" <>) . (<> "}'") . mconcat . intersperse ","+ . map (("\"" <>) . (<> "\"") . escapeByteString)+ . (>>= vectorToList . toRow backend)++escapeByteString :: BS.ByteString -> BS.ByteString+escapeByteString bs =+ case fmap (BS.splitAt 1) (BS.span (\c -> c /= '\\' && c /= '"') bs) of+ (bs', ("\\", bs'')) -> bs' <> "\\\\" <> escapeByteString bs''+ (bs', ("\"", bs'')) -> bs' <> "\\\"" <> escapeByteString bs''+ (bs', _) -> bs'