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 (typeName 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 FromRow PSQL One a => FromRow PSQL One [a] where
fromRow = pconsume `pbind` \(col@ColumnInfo{..}, Field{..}) ->
case (typeType colInfoType, fieldValue) of
(TTArray subtype, Just bs) ->
pbackend `pbind` \backend ->
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"
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)
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 <- 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.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.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"