Handle date with parsing on PS side

src/Database/PostgreSQL/Value.js

@@ -1,5 +1,12 @@
 'use strict';
 
+// pg does strange thing converting DATE
+// value to js Date, so we have
+// to prevent this craziness
+var pg = require('pg');
+var DATE_OID = 1082;
+pg.types.setTypeParser(DATE_OID, function(dateString) { return dateString; });
+
 exports['null'] = null;
 
 exports.instantToString = function(i) {

src/Database/PostgreSQL/Value.purs

@@ -8,14 +8,18 @@ import Control.Monad.Except (runExcept)
 import Data.Array as Array
 import Data.Bifunctor (lmap)
 import Data.ByteString (ByteString)
+import Data.Date (Date, canonicalDate, day, month, year)
 import Data.DateTime.Instant (Instant, instant)
 import Data.Decimal (Decimal)
 import Data.Decimal as Decimal
 import Data.Either (Either(..), note)
+import Data.Enum (fromEnum, toEnum)
 import Data.Foreign (Foreign, isNull, readArray, readBoolean, readChar, readInt, readNumber, readString, toForeign, unsafeFromForeign)
+import Data.Int (fromString)
 import Data.List (List)
 import Data.List as List
 import Data.Maybe (Maybe(..))
+import Data.String (Pattern(..), split)
 import Data.Time.Duration (Milliseconds(..))
 import Data.Traversable (traverse)
 
@@ -82,9 +86,33 @@ instance toSQLValueInstant :: ToSQLValue Instant where
 
 instance fromSQLValueInstant :: FromSQLValue Instant where
     fromSQLValue v = do
-      t ← instantFromString Left Right v
+      t <- instantFromString Left Right v
       note ("Instant construction failed for given timestamp: " <> show t) $ instant (Milliseconds t)
 
+instance toSQLValueDate :: ToSQLValue Date where
+    toSQLValue date =
+        let
+            y = fromEnum $ year date
+            m = fromEnum $ month date
+            d = fromEnum $ day date
+        in
+            toForeign $ show y <> "-" <> show m <> "-" <> show d
+
+instance fromSQLValueDate :: FromSQLValue Date where
+    fromSQLValue v = do
+        s <- lmap show $ runExcept (readString v)
+        let
+            msg = "Date parsing failed for value: " <> s
+        case split (Pattern "-") s of
+            [y, m, d] -> do
+                let
+                  result = canonicalDate
+                    <$> (toEnum =<< fromString y)
+                    <*> (toEnum =<< fromString m)
+                    <*> (toEnum =<< fromString d)
+                note msg result
+            _ -> Left msg
+
 instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
     toSQLValue Nothing = null
     toSQLValue (Just x) = toSQLValue x
@@ -104,10 +132,10 @@ instance toSQLValueDecimal :: ToSQLValue Decimal where
 
 instance fromSQLValueDecimal :: FromSQLValue Decimal where
     fromSQLValue v = do
-        s ← lmap show $ runExcept (readString v)
+        s <- lmap show $ runExcept (readString v)
         note ("Decimal literal parsing failed: " <> s) (Decimal.fromString s)
 
 foreign import null :: Foreign
 foreign import instantToString :: Instant -> Foreign
-foreign import instantFromString :: (String → Either String Number) → (Number → Either String Number) → Foreign → Either String Number
+foreign import instantFromString :: (String -> Either String Number) -> (Number -> Either String Number) -> Foreign -> Either String Number
 foreign import unsafeIsBuffer :: ∀ a. a -> Boolean

test/Main.purs

@@ -12,19 +12,24 @@ import Control.Monad.Eff.Class (liftEff)
 import Control.Monad.Eff.Exception (EXCEPTION, error)
 import Control.Monad.Eff.Now (NOW)
 import Control.Monad.Error.Class (catchError, throwError, try)
+import Data.Array (zip)
+import Data.Date (Date, canonicalDate)
 import Data.DateTime.Instant (Instant, unInstant)
 import Data.Decimal as D
-import Data.Foldable (all)
+import Data.Enum (toEnum)
+import Data.Foldable (all, length)
 import Data.JSDate (toInstant)
 import Data.JSDate as JSDate
 import Data.Maybe (Maybe(..), fromJust)
 import Data.Newtype (unwrap)
+import Data.Tuple (Tuple(..))
 import Database.PostgreSQL (Connection, POSTGRESQL, PoolConfiguration, Query(Query), Row0(Row0), Row1(Row1), Row2(Row2), Row3(Row3), Row9(Row9), execute, newPool, query, scalar, withConnection, withTransaction)
 import Math ((%))
 import Partial.Unsafe (unsafePartial)
 import Test.Assert (ASSERT, assert)
 import Test.Unit (suite)
 import Test.Unit as Test.Unit
+import Test.Unit.Assert (equal)
 import Test.Unit.Console (TESTOUTPUT)
 import Test.Unit.Main (runTest)
 
@@ -50,7 +55,18 @@ test conn t a = Test.Unit.test t (withRollback conn a)
 now :: ∀ eff.  Eff (now :: NOW | eff) Instant
 now = unsafePartial $ (fromJust <<< toInstant) <$> JSDate.now
 
-main :: ∀ eff. Eff (assert :: ASSERT, avar :: AVAR, console :: CONSOLE, exception :: EXCEPTION, now :: NOW, postgreSQL :: POSTGRESQL, testOutput :: TESTOUTPUT | eff) Unit
+main
+  :: ∀ eff
+   . Eff
+      ( assert :: ASSERT
+      , avar :: AVAR
+      , console :: CONSOLE
+      , exception :: EXCEPTION
+      , now :: NOW
+      , postgreSQL :: POSTGRESQL
+      , testOutput :: TESTOUTPUT | eff
+      )
+      Unit
 main = void $ launchAff do
   pool <- newPool config
   withConnection pool \conn -> do
@@ -61,7 +77,10 @@ main = void $ launchAff do
         price NUMERIC(4,2) NOT NULL,
         added TIMESTAMP WITH TIME ZONE NOT NULL DEFAULT CURRENT_TIMESTAMP,
         PRIMARY KEY (name)
-     )
+      );
+      CREATE TEMPORARY TABLE dates (
+        date date NOT NULL
+      );
     """) Row0
 
     liftEff $ runTest $ do
@@ -115,7 +134,7 @@ main = void $ launchAff do
           """) Row0
           liftEff <<< assert $ names == [Row2 "pork" true, Row2 "rookworst" true]
 
-        test conn "select default instant value" $ do
+        test conn "handling instant value" $ do
           before <- liftEff $ (unwrap <<< unInstant) <$> now
           insertFood
           added <- query conn (Query """
@@ -131,7 +150,7 @@ main = void $ launchAff do
                 && after >= (unwrap $ unInstant t))
             added
 
-        test conn "select decimal" $ do
+        test conn "handling decimal value" $ do
           insertFood
           sauerkrautPrice <- query conn (Query """
             SELECT price
@@ -140,6 +159,27 @@ main = void $ launchAff do
           """) Row0
           liftEff <<< assert $ sauerkrautPrice == [Row1 (D.fromString "3.30")]
 
+        test conn "handling date value" $ do
+          let
+            date y m d =
+              canonicalDate <$> toEnum y <*>  toEnum m <*> toEnum d
+            d1 = unsafePartial $ fromJust $ date 2010 2 31
+            d2 = unsafePartial $ fromJust $ date 2017 2 1
+            d3 = unsafePartial $ fromJust $ date 2020 6 31
+
+          execute conn (Query """
+            INSERT INTO dates (date)
+            VALUES ($1), ($2), ($3)
+          """) (Row3 d1 d2 d3)
+
+          (dates :: Array (Row1 Date)) <- query conn (Query """
+            SELECT *
+            FROM dates
+            ORDER BY date ASC
+          """) Row0
+          equal 3 (length dates)
+          liftEff <<< assert $ all (\(Tuple (Row1 r) e) -> e == r) $ (zip dates [d1, d2, d3])
+
 
 config :: PoolConfiguration
 config =