From 552e59ad92380e9fb3642f35ae6b7630bc8bc77e Mon Sep 17 00:00:00 2001
From: rightfold <rightfold@gmail.com>
Date: Tue, 18 Apr 2017 14:33:43 +0200
Subject: [PATCH] Use more descriptive error messages for invalid row
 structures

---
 src/Database/PostgreSQL.purs | 38 +++++++++++++++++++-----------------
 1 file changed, 20 insertions(+), 18 deletions(-)

diff --git a/src/Database/PostgreSQL.purs b/src/Database/PostgreSQL.purs
index 3016d29..51273b8 100644
--- a/src/Database/PostgreSQL.purs
+++ b/src/Database/PostgreSQL.purs
@@ -25,6 +25,7 @@ import Control.Monad.Eff.Exception (error)
 import Control.Monad.Error.Class (catchError, throwError)
 import Control.Monad.Except (runExcept)
 import Data.Array (head, uncons)
+import Data.Bifunctor (lmap)
 import Data.ByteString (ByteString)
 import Data.DateTime.Instant (Instant)
 import Data.Either (Either(..))
@@ -69,7 +70,7 @@ class ToSQLRow a where
 
 -- | Convert things from SQL rows.
 class FromSQLRow a where
-    fromSQLRow :: Array Foreign -> Maybe a
+    fromSQLRow :: Array Foreign -> Either String a
 
 -- | Convert things to SQL values.
 class ToSQLValue a where
@@ -77,7 +78,7 @@ class ToSQLValue a where
 
 -- | Convert things from SQL values.
 class FromSQLValue a where
-    fromSQLValue :: Foreign -> Maybe a
+    fromSQLValue :: Foreign -> Either String a
 
 instance toSQLRowUnit :: ToSQLRow Unit where
     toSQLRow _ = []
@@ -86,56 +87,57 @@ instance toSQLRowTuple :: (ToSQLValue a, ToSQLRow b) => ToSQLRow (Tuple a b) whe
     toSQLRow (a /\ b) = [toSQLValue a] <> toSQLRow b
 
 instance fromSQLRowUnit :: FromSQLRow Unit where
-    fromSQLRow [] = Just unit
-    fromSQLRow _ = Nothing
+    fromSQLRow [] = pure unit
+    fromSQLRow _ = throwError "FromSQLRow: row has too many columns"
 
 instance fromSQLRowTuple :: (FromSQLValue a, FromSQLRow b) => FromSQLRow (Tuple a b) where
-    fromSQLRow = uncons >=> case _ of
-      {head, tail} -> (/\) <$> fromSQLValue head <*> fromSQLRow tail
+    fromSQLRow = uncons >>> case _ of
+      Just {head, tail} -> (/\) <$> fromSQLValue head <*> fromSQLRow tail
+      Nothing -> throwError "FromSQLRow: row has too few columns"
 
 instance toSQLValueBoolean :: ToSQLValue Boolean where
     toSQLValue = toForeign
 
 instance fromSQLValueBoolean :: FromSQLValue Boolean where
-    fromSQLValue = fromRight <<< runExcept <<< readBoolean
+    fromSQLValue = lmap show <<< runExcept <<< readBoolean
 
 instance toSQLValueChar :: ToSQLValue Char where
     toSQLValue = toForeign
 
 instance fromSQLValueChar :: FromSQLValue Char where
-    fromSQLValue = fromRight <<< runExcept <<< readChar
+    fromSQLValue = lmap show <<< runExcept <<< readChar
 
 instance toSQLValueInt :: ToSQLValue Int where
     toSQLValue = toForeign
 
 instance fromSQLValueInt :: FromSQLValue Int where
-    fromSQLValue = fromRight <<< runExcept <<< readInt
+    fromSQLValue = lmap show <<< runExcept <<< readInt
 
 instance toSQLValueNumber :: ToSQLValue Number where
     toSQLValue = toForeign
 
 instance fromSQLValueNumber :: FromSQLValue Number where
-    fromSQLValue = fromRight <<< runExcept <<< readNumber
+    fromSQLValue = lmap show <<< runExcept <<< readNumber
 
 instance toSQLValueString :: ToSQLValue String where
     toSQLValue = toForeign
 
 instance fromSQLValueString :: FromSQLValue String where
-    fromSQLValue = fromRight <<< runExcept <<< readString
+    fromSQLValue = lmap show <<< runExcept <<< readString
 
 instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
-    fromSQLValue = traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray
+    fromSQLValue = traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray
 
 instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
-    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray
+    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray
 
 instance toSQLValueByteString :: ToSQLValue ByteString where
     toSQLValue = toForeign
 
 instance fromSQLValueByteString :: FromSQLValue ByteString where
     fromSQLValue x
-        | unsafeIsBuffer x = Just $ unsafeFromForeign x
-        | otherwise = Nothing
+        | unsafeIsBuffer x = pure $ unsafeFromForeign x
+        | otherwise = throwError "FromSQLValue ByteString: not a buffer"
 
 instance toSQLValueInstant :: ToSQLValue Instant where
     toSQLValue = instantToString
@@ -145,7 +147,7 @@ instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
     toSQLValue (Just x) = toSQLValue x
 
 instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
-    fromSQLValue x | isNull x  = Just Nothing
+    fromSQLValue x | isNull x  = pure Nothing
                    | otherwise = Just <$> fromSQLValue x
 
 foreign import instantToString :: Instant -> Foreign
@@ -202,8 +204,8 @@ query
 query conn (Query sql) values =
     _query conn sql (toSQLRow values)
     >>= traverse (fromSQLRow >>> case _ of
-          Just row -> pure row
-          Nothing  -> throwError (error "incompatible row structure"))
+          Right row -> pure row
+          Left  msg -> throwError (error msg))
 
 scalar
     :: ∀ i o eff