ihp-postgresql-simple-extra-1.3.0: IHP/Postgres/Point.hs

{-# LANGUAGE TemplateHaskell #-}
{-|
Module: IHP.Postgres.Point
Description: Adds support for the Postgres Point type
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.Postgres.Point where

import GHC.Float
import BasicPrelude

import Database.PostgreSQL.Simple.ToField
import Database.PostgreSQL.Simple.FromField
import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
import           Database.PostgreSQL.Simple.TypeInfo.Macro as TI
import           Data.ByteString.Builder (byteString, char8)
import           Data.Attoparsec.ByteString.Char8 hiding (Result, char8, Parser(..))
import Data.Attoparsec.Internal.Types (Parser)
import Data.Aeson

-- | Represents a Postgres Point
--
-- See https://www.postgresql.org/docs/9.5/datatype-geometric.html
data Point = Point { x :: Double, y :: Double }
    deriving (Eq, Show, Ord)

instance FromField Point where
    fromField f v =
        if typeOid f /= $(inlineTypoid TI.point)
        then returnError Incompatible f ""
        else case v of
               Nothing -> returnError UnexpectedNull f ""
               Just bs ->
                   case parseOnly parsePoint bs of
                     Left  err -> returnError ConversionFailed f err
                     Right val -> pure val

parsePoint :: Parser ByteString Point
parsePoint = do
    string "("
    x <- doubleOrNaN
    string ","
    y <- doubleOrNaN
    string ")"
    pure $ Point { x, y }
        where
            -- Postgres supports storing NaN inside a point, so we have to deal
            -- with that here as well
            doubleOrNaN = double <|> (string "NaN" >> (pure $ 0 / 0))


instance ToField Point where
    toField = serializePoint

serializePoint :: Point -> Action
serializePoint Point { x, y } = Many
    [ Plain (byteString "point(")
    , toField x
    , Plain (char8 ',')
    , toField y
    , Plain (char8 ')')
    ]


instance FromJSON Point where
    parseJSON = withObject "Point" $ \v -> Point
        <$> v .: "x"
        <*> v .: "y"

instance ToJSON Point where
    toJSON Point { x, y } = object [ "x" .= x, "y" .= y ]