Opaleye dynamic fields

dynamic-fields.hs

-- Requires branch https://github.com/tomjaguarpaw/haskell-opaleye/tree/dynamic-fields
--
-- If you use this please contact me http://web.jaguarpaw.co.uk/~tom/contact/ and let me
-- know what you think.

import Data.String

import Opaleye
import Opaleye.Internal.Dynamic (SqlDynamic, Dynamic,
                                 stringFromFields, stringUnpackspec)
import Opaleye.Internal.Table (DynamicTableFields, fromDynamicTableFields,
                               dynamic)

import qualified Database.PostgreSQL.Simple as S
import qualified Database.PostgreSQL.Simple.Options as O
import qualified Database.Postgres.Temp as T

import Data.Profunctor.Product (list, p2, p3, ProductProfunctor, SumProfunctor)
import Data.Profunctor.Product.Default (Default, def)

import Lens.Micro (traverseOf, _2, LensLike)

import Data.Void (Void)
import GHC.Int (Int64)
import GHC.IO.Exception (ExitCode)

dynamicTable :: Table Void [(String, Field SqlDynamic)]
dynamicTable =
  table "dynamicTable"
        (dynamicFields (traverse._2)
          [ ("name", "name_field")
          , ("age", "age_field")
          , ("loves haskell?", "loves_haskell")
          ])

main :: IO ()
main = do
  withTempDBConnection $ \connection -> do
    createTable connection
    -- Running these dynamically typed queries is just for people who
    -- like product-profunctors, until I work out what to do about the
    -- Default instances.
    ss <- runSelectString connection (selectTableString dynamicTable)
    mapM_ print ss
  pure ()

-- Output:
--
-- [("name",String "Ashok"),("age",Int 25),("loves haskell?",Bool True)]
-- [("name",String "Bjarne"),("age",Int 69),("loves haskell?",Bool False)]
-- [("name",String "Cui"),("age",Int 36),("loves haskell?",Bool True)]

runSelectString :: S.Connection
                -> Select [(String, Column SqlDynamic)]
                -> IO [[(String, Dynamic)]]
runSelectString = runSelectExplicit (explicit stringFromFields)

selectTableString :: Table a [(String, Column SqlDynamic)]
                  -> Select [(String, Column SqlDynamic)]
selectTableString = selectTableExplicit (matchType (explicit stringUnpackspec))
  where matchType :: p a a -> p a a
        matchType = id

explicit :: (SumProfunctor p, ProductProfunctor p, Default p a' b')
         => p a b -> p [(a, a')] [(b, b')]
explicit s = list (p2 (s, def))

dynamicFields
  :: LensLike (DynamicTableFields Void) s viewColumns String (Column a)
  -> s -> TableFields Void viewColumns
dynamicFields f = fromDynamicTableFields . traverseOf f dynamic

-- We'll use a static representation of the data for inserting the
-- data
staticTable :: Table (Field SqlText, Field SqlInt4, Field SqlBool)
                     (Field SqlText, Field SqlInt4, Field SqlBool)
staticTable =
  table "dynamicTable" (p3 ( required "name_field"
                           , required "age_field"
                           , required "loves_haskell"
                           ))

createTable :: S.Connection -> IO Int64
createTable connection = do
    S.execute_ connection (fromString
      ("CREATE TABLE \"dynamicTable\" (name_field text, "
       ++ "age_field int4, loves_haskell bool);"))

    runInsert_ connection Insert {
        iTable      = staticTable
      , iRows       = map toFields [ ("Ashok", 25 :: Int, True)
                                   , ("Bjarne", 69, False)
                                   , ("Cui", 36, True)
                                   ]
      , iReturning  = rCount
      , iOnConflict = Nothing
      }

withTempDBConnection :: (S.Connection -> IO a)
                     -> IO (Maybe ExitCode)
withTempDBConnection f = do
  result <- T.start T.defaultOptions
  case result of
    Left err -> print err >> pure Nothing
    Right tempDB -> do
      connection <- S.connectPostgreSQL (O.toConnectionString (T.options tempDB))
      f connection
      T.stop tempDB