Haskell persistent Postresql native PostGIS Geolocation encoding

migration.sql

-- migrate:up
-- PostGIS enables PostgreSQL to handle spatial data and perform complex
-- geographic operations, making it a
-- powerful tool for applications that require geospatial capabilities.
-- GEOGRAPHY: This is a PostGIS data type used to store geographic data, which takes into account the Earth's curvature.
-- Point: This specifies that the data type is a point, representing a single location with latitude and longitude.
-- 4326: This is the Spatial Reference System Identifier (SRID) for WGS 84, a standard coordinate system used globally for GPS and mapping.
CREATE EXTENSION IF NOT EXISTS postgis;
ALTER TABLE <mytable> ADD COLUMN location GEOGRAPHY(Point, 4326) NULL;
CREATE INDEX <mytable>_location_idx ON realty USING GIST (location);

PersistentPostgressGeolocation.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Storage.Geolocation where

import Data.Binary.Get (Get, getDoublebe, getDoublele, getWord32be, getWord32le, getWord8, runGetOrFail)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy qualified as BL
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Word (Word8)
import Database.Persist.Sql
    ( PersistValue(PersistLiteral_, PersistLiteralEscaped),
      PersistField(..),
      SqlType(SqlOther),
      PersistFieldSql(..) )
import Numeric (readHex, showHex)
import Text.Read (readMaybe)

-- | Represents a geographical point with latitude and longitude
data Geolocation = Geolocation
    { latitude :: Double
    , longitude :: Double
    }
    deriving stock (Show, Eq)

-- | Custom PersistField instance for Geography
instance PersistField Geolocation where
    toPersistValue (Geolocation lat lon) =
        PersistLiteralEscaped $ TE.encodeUtf8 $ "SRID=4326;POINT(" <> (T.pack $ show lon) <> " " <> (T.pack $ show lat) <> ")"

    fromPersistValue (PersistLiteral_ l bs) = case parseEWKB (hexToByteString $ B.unpack bs) of
        Just (lat, lon) -> Right $ Geolocation lat lon
        -- Nothing -> Left $ T.pack "Invalid Geolocation point format " <> (TE.decodeUtf8 bs)
        Nothing -> Left $ T.pack $ "Invalid Geolocation point format " <> show l <> byteStringToHex bs <> " " <> show (TE.decodeUtf8 bs)
    fromPersistValue _ = Left "Invalid Geolocation value"

-- | Custom PersistFieldSql instance for Geolocation
instance PersistFieldSql Geolocation where
    sqlType _ = SqlOther "geography"

-- | Helper function to parse EWKB format
parseEWKB :: B.ByteString -> Maybe (Double, Double)
parseEWKB bs = case runGetOrFail getPoint (BL.fromStrict bs) of
    Right (_, _, (lon, lat)) -> Just (lat, lon)
    -- Right _ -> Nothing
    Left _ -> Nothing

getPoint :: Get (Double, Double)
getPoint = do
    byteOrder <- getWord8
    let getDouble = if byteOrder == 0 then getDoublebe else getDoublele
    let getWord = if byteOrder == 0 then getWord32be else getWord32le
    _ewkbType <- getWord -- EWKB type
    _srid <- getWord -- SRID
    lon <- getDouble
    lat <- getDouble
    pure (lon, lat)

-- | Function to convert hex string to ByteString
hexToByteString :: String -> B.ByteString
hexToByteString = BS.pack . mapMaybe (fmap (fromIntegral @Integer @Word8 . fst) . listToMaybe . readHex) . chunksOf 2
  where
    chunksOf _ [] = []
    chunksOf n xs = take n xs : chunksOf n (drop n xs)

-- | Helper function to parse POINT format
parsePoint :: Text -> Maybe (Double, Double)
parsePoint t =
    let parts = T.splitOn " " $ T.dropAround (`elem` ("();SRID=4326;POINT" :: String)) t
     in case parts of
            [lon, lat] -> (,) <$> readMaybe (T.unpack lat) <*> readMaybe (T.unpack lon)
            _ -> Nothing

byteStringToHex :: B.ByteString -> String
byteStringToHex = concatMap (`showHex` "") . BS.unpack