seakale-postgresql 0.2.0.1 → 0.3.0.0

raw patch · 5 files changed

+147/−45 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• seakale-postgresql.cabal +4/−2
• src/Database/Seakale/PostgreSQL.hs +87/−14
• src/Database/Seakale/PostgreSQL/FromRow.hs +46/−29
• src/Database/Seakale/PostgreSQL/ToRow.hs +6/−0

@@ -1,5 +1,9 @@ # Revision history for seakale-postgresql +## 0.3.0.0 -- 2017-03-30++* Support for composite types (with Composite a)+ ## 0.2.0.1 -- 2017-03-20  * Fix ToRow instance of lists.

@@ -1,5 +1,5 @@ name:                  seakale-postgresql-version:               0.2.0.1+version:               0.3.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@@ -14,7 +14,7 @@ source-repository head   type:                darcs   location:            http://darcs.redspline.com/seakale-  tag:                 seakale-postgresql-0.2.0.1+  tag:                 seakale-postgresql-0.3.0.0  library   ghc-options:         -Wall@@ -31,6 +31,8 @@                        RecordWildCards                        OverloadedStrings                        FlexibleContexts+                       TupleSections+                       UndecidableInstances    exposed-modules:     Database.Seakale.PostgreSQL                        Database.Seakale.PostgreSQL.FromRow

@@ -17,6 +17,8 @@   , runStore   , runStoreT   , HasConnection(..)+  , TypeInfo(..)+  , TypeType(..)   , PSQL(..)   , defaultPSQL   , SeakaleError(..)@@ -39,6 +41,8 @@   , Eight   , Nine   , Ten+  -- * Specific types+  , Composite(..)   ) where  import           Control.Monad.Except@@ -47,6 +51,8 @@ import           Control.Monad.State import           Control.Monad.Trans.Free +import           Data.Function+import           Data.List import           Data.Maybe import           Data.Monoid import           Data.Word@@ -116,15 +122,28 @@     put s'     return x -type TypeCache = [(Oid, BS.ByteString)]+type TypeInfoOid = (BS.ByteString, Maybe [(BS.ByteString, Oid)], Maybe Oid) +data TypeType+  = TTComposite [(BS.ByteString, TypeInfo)]+  | TTArray TypeInfo+  | TTOther+  deriving Show++data TypeInfo = TypeInfo+  { typeName :: BS.ByteString+  , typeType :: TypeType+  } deriving Show++type TypeCache = [(Oid, TypeInfoOid)]+ data PSQL = PSQL { psqlLogQueries :: Bool }  defaultPSQL :: PSQL defaultPSQL = PSQL False  instance Backend PSQL where-  type ColumnType PSQL = BS.ByteString+  type ColumnType PSQL = TypeInfo    type MonadBackend PSQL m = ( HasConnection m                              , MonadState TypeCache m@@ -204,9 +223,22 @@     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 :: MonadBackend PSQL m => Oid -> ExceptT BS.ByteString m TypeInfo resolveType oid = do+  (name, mAttrs, mElemOID) <- resolveTypeOid oid+  case (mAttrs, mElemOID) of+    (Nothing, Nothing) -> return $ TypeInfo name TTOther+    (Just attrs, Nothing) -> do+      attrs' <- mapM (\(aname, aoid) -> (aname,) <$> resolveType aoid) attrs+      return $ TypeInfo name $ TTComposite attrs'+    (Nothing, Just eoid) -> do+      etinfo <- resolveType eoid+      return $ TypeInfo name $ TTArray etinfo+    _ -> throwError $ "Can't resolve type " <> name++resolveTypeOid :: MonadBackend PSQL m => Oid+               -> ExceptT BS.ByteString m TypeInfoOid+resolveTypeOid oid = do   cache <- get   case lookup oid cache of     Just n  -> return n@@ -219,18 +251,57 @@  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+    -- It uses { for separator as a hack to force the presence of double quotes+    res <- exec' "SELECT pg_type.oid, typname, typtype, typelem, typlen,\+                 \ array_agg(attnum || '{' || attname || '{' || atttypid)\+                 \ FROM pg_type LEFT JOIN pg_attribute ON attrelid = typrelid\+                 \ AND typrelid <> 0 GROUP BY oid, typname, typtype, typelem,\+                 \ typlen"+    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"+    forM (_until nrows) $ \row -> do+      oidBS  <- liftIO $ getvalue' res row 0+      nameBS <- liftIO $ getvalue' res row 1+      typeBS <- liftIO $ getvalue' res row 2+      elemBS <- liftIO $ getvalue' res row 3+      lenBS  <- liftIO $ getvalue' res row 4+      attBS  <- liftIO $ getvalue' res row 5 +      case ( fmap (reads . BS.unpack) oidBS, nameBS, typeBS+           , fmap (reads . BS.unpack) elemBS, lenBS, attBS ) of+        (Just ((i,"") : _), Just name, _, Just ((e,""):_), Just "-1", _)+          | e /= 0 -> return ( Oid (fromInteger i)+                             , (name, Nothing, Just (Oid (fromInteger e))) )+        (Just ((i,"") : _), Just name, Just "c", _, _, Just bs) -> do+          attrs <- case readAttrs bs of+            Nothing ->+              throwError $ "Can't read attributes of composite type: " <> bs+            Just as -> return as+          return (Oid (fromInteger i), (name, Just attrs, Nothing))+        (Just ((i,"") : _), Just name, _, _, _, _) ->+          return (Oid (fromInteger i), (name, Nothing, Nothing))+        _ -> throwError "Can't read types from pg_type"++  where+    readAttrs :: BS.ByteString -> Maybe [(BS.ByteString, Oid)]+    readAttrs bs = do+      stripped <- (BS.stripPrefix "{" >=> BS.stripSuffix "}") bs+      bsTuples <- forM (BS.split ',' stripped) $ \sub -> do+        strippedSub <- (BS.stripPrefix "\"" >=> BS.stripSuffix "\"") sub+        return $ BS.split '{' strippedSub++      tuples <- forM bsTuples $ \att -> case att of+        [attnum, attname, atttypid] ->+          case (reads (BS.unpack attnum), reads (BS.unpack atttypid)) of+            ((n,""):_, (i,""):_) ->+              Just (n :: Int, attname, Oid (fromInteger i))+            _ -> Nothing+        _ -> Nothing++      return $ map (\(_,n,i) -> (n,i)) $ sortBy (compare `on` (\(n,_,_) -> n)) $+        filter (\(n,_,_) -> n > 0) tuples+ exec' :: MonadBackend PSQL m => BS.ByteString       -> ExceptT BS.ByteString m Result exec' req = do@@ -255,3 +326,5 @@     _ -> return ()    return res++newtype Composite a = Composite { fromComposite :: a } deriving (Show, Eq)

@@ -20,7 +20,7 @@  instance FromRow PSQL One UTCTime where   fromRow = pconsume `pbind` \(ColumnInfo{..}, Field{..}) ->-    case (colInfoType, fieldValue) of+    case (typeName colInfoType, fieldValue) of       ("timestamp", Just bs) ->         case parseTimeM True defaultTimeLocale "%F %T%Q" (BS.unpack bs) of           Just t  -> preturn t@@ -38,46 +38,63 @@  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) ->+    case (typeType colInfoType, fieldValue) of+      (TTArray subtype, Just bs) ->         pbackend `pbind` \backend ->-        arrayParser backend (col { colInfoType = typ }) bs-      (_, Just _) -> pfail $ "invalid type for list: " ++ BS.unpack colInfoType+          let col'  = col { colInfoType = subtype }+              f mBS = parseRow fromRow backend [col'] [Field mBS]+          in either pfail preturn $ seqParser '{' '}' "array" f bs+      (_, Just _) ->+        pfail $ "invalid type for list: " ++ BS.unpack (typeName colInfoType)       (_, Nothing) -> pfail "unexpected NULL for list"  -- FIXME: What about \n for example?-arrayParser :: FromRow PSQL One a => PSQL -> ColumnInfo PSQL -> BS.ByteString-            -> RowParser PSQL Zero [a]-arrayParser backend 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)+seqParser :: Char -> Char -> String -> (Maybe BS.ByteString -> Either String a)+          -> BS.ByteString -> Either String [a]+seqParser ldelim rdelim descr h fullBS = case BS.uncons fullBS of+    Just (ldelim', rdelim')+      | ldelim == ldelim' && BS.singleton rdelim == rdelim' -> return []+    Just (ldelim', bs') | ldelim == ldelim' -> readValues h id bs'+    _ -> Left $ "invalid " ++ descr ++ " starting with "+                ++ show (BS.take 30 fullBS) -    readValues :: FromRow PSQL One a => ([a] -> [a]) -> BS.ByteString-               -> Either String [a]-    readValues f bs = do+  where+    readValues :: (Maybe BS.ByteString -> Either String a) -> ([a] -> [a])+               -> BS.ByteString -> Either String [a]+    readValues f g bs = do       (valBS, bs') <- readByteString bs       let mValBS = if valBS == "NULL" then Nothing else Just valBS-      val <- parseRow fromRow backend [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')+      val <- f mValBS+      case BS.uncons bs' of+        Just (',', bs'') -> readValues f (g . (val :)) bs''+        Just (rdelim', "") | rdelim == rdelim' -> return $! g [val]+        _ -> Left $ "invalid " ++ descr ++ " 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 = case BS.uncons bs of+      Just ('"', bs') -> readByteString' "" bs'+      _ -> return $ BS.span (\c -> c /= ',' && c /= rdelim) 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'''+      case fmap BS.uncons (BS.span (\c -> c /= '"' && c /= '\\') bs) of+        (bs', Just ('"', bs'')) -> case BS.uncons bs'' of+          Just ('"', bs''') -> readByteString' (bs' <> "\"") bs'''+          _ -> return (acc <> bs', bs'')+        (bs', Just ('\\', bs'')) -> let (c, bs''') = BS.splitAt 1 bs''+                                    in readByteString' (acc <> bs' <> c) bs'''         (bs', _) -> Left $ "unreadable value around " ++ show (BS.take 30 bs')++instance (Show a, FromRow PSQL n a) => FromRow PSQL One (Composite a) where+  fromRow = pconsume `pbind` \(ColumnInfo{..}, Field{..}) ->+    case (typeType colInfoType, fieldValue) of+      (TTComposite attrs, Just bs) -> pbackend `pbind` \backend ->+        either pfail preturn $ do+          let cols = map (\(name, tinfo) -> ColumnInfo (Just name) tinfo) attrs+          fields <- seqParser '(' ')' (BS.unpack (typeName colInfoType))+                              (Right . Field) bs+          Composite <$> parseRow fromRow backend cols fields+      (_, Just _) -> pfail $ "expected composite type"+      (_, Nothing) -> pfail "unexpected NULL for composite type"

@@ -44,3 +44,9 @@ trimOuterQuotes bs =   let bs' = case BS.splitAt 1 bs of { ("'", b) -> b; _ -> bs }   in case BS.unsnoc bs' of { Just (bs'', '\'') -> bs''; _ -> bs' }++instance ToRow PSQL n a => ToRow PSQL One (Composite a) where+  toRow backend =+    singleton . Just . ("'(" <>) . (<> ")'") . mconcat . intersperse ","+    . map (("\"" <>) . (<> "\"") . escapeByteString . trimOuterQuotes)+    . map (fromMaybe "NULL") . vectorToList . toRow backend . fromComposite