Move from Beam to Squeal

.gitignore

@@ -2,3 +2,6 @@
 analytics.cabal
 .DS_Store
 *~
+tags
+dist-newstyle/
+hie.yaml

db/Migrations.hs

@@ -1,22 +1,12 @@
-import           Database.PostgreSQL.Simple           (withTransaction)
-import           Database.PostgreSQL.Simple.Migration (MigrationCommand (..),
-                                                       MigrationContext (..),
-                                                       MigrationResult (..),
-                                                       runMigration)
-import           Context                              (Ctx (..),
-                                                       readContextFromEnv)
+import           Context                              (connStr, readContextFromEnv)
+import Squeal.PostgreSQL
+import Squeal.Migration.V1 (initMigration)
+
+{-
+ There needs to be some level of error reporting here?
+ -}
 main :: IO ()
 main = do
   ctx <- readContextFromEnv
-  let migrationDir = MigrationDirectory "db/migrations/"
-  let con = conn ctx
-  initResult <- withTransaction con $ runMigration $
-    MigrationContext MigrationInitialization False con
-  case initResult of
-    MigrationError _ -> do
-      putStrLn "failed to run intialization"
-      print initResult
-    MigrationSuccess -> do
-      migrationResult <- withTransaction con $ runMigration $
-        MigrationContext migrationDir True con
-      print migrationResult
+  withConnection (connStr ctx) $
+    define initMigration

package.yaml

@@ -24,58 +24,57 @@ ghc-options:
 - -Wtype-defaults
 
 default-extensions:
+- AllowAmbiguousTypes
 - BlockArguments
-- OverloadedStrings
 - DataKinds
-- TypeOperators
 - DeriveAnyClass
 - DeriveGeneric
-- TypeApplications
-- GADTs
+- DerivingStrategies
 - FlexibleContexts
 - FlexibleInstances
-- TypeFamilies
-- StandaloneDeriving
-- RecordWildCards
-- PartialTypeSignatures
+- GADTs
+- GeneralizedNewtypeDeriving
+- LambdaCase
+- MultiParamTypeClasses
 - NamedFieldPuns
 - NoMonomorphismRestriction
-- MultiParamTypeClasses
-- LambdaCase
-- AllowAmbiguousTypes
-
-# Metadata used when publishing your package
-# synopsis:            Short description of your package
-# category:            Web
-
-# To avoid duplicated efforts in documentation and dealing with the
-# complications of embedding Haddock markup inside cabal files, it is
-# common to point users to the README.md file.
-description:         Please see the README on GitHub at <https://github.com/adamwespiser/analytics#readme>
+- OverloadedLabels
+- OverloadedStrings
+- PartialTypeSignatures
+- PatternSynonyms
+- StandaloneDeriving
+- RecordWildCards
+- RankNTypes
+- ScopedTypeVariables
+- TypeOperators
+- TypeApplications
+- TypeFamilies
 
 dependencies:
-- base >= 4.7 && < 5
-- servant >= 0.16.2
-- wai >= 3.2.2.1
-- wai-extra >= 3.0.28
-- warp >= 3.2.28
-- servant-server
-- servant-client
+- base >= 4.7
+- aeson >= 1.4.5.0
+- bytestring >= 0.10.8.2
+- exceptions
+- generics-sop
 - http-client
 - http-types
+- postgresql-simple
+- extra >= 1.6.18
+- mtl >= 2.2.2
+- safe >= 0.3.17
+- servant >= 0.16.2
+- servant-client
+- servant-server
+- servant-options >= 0.1.0.0
+- squeal-postgresql
 - text >= 1.2.3.1
-- aeson >= 1.4.5.0
-- beam-core >= 0.8.0.0
-- beam-postgres >= 0.4.0.0
 - time >= 1.8.0.2
-- bytestring >= 0.10.8.2
 - transformers >= 0.5.6.2
-- extra >= 1.6.18
-- safe >= 0.3.17
 - uuid-types >= 1.0.3
+- wai >= 3.2.2.1
 - wai-cors >= 0.2.7
-- servant-options >= 0.1.0.0
-- mtl >= 2.2.2
+- wai-extra >= 3.0.28
+- warp >= 3.2.28
 
 library:
   source-dirs: src
@@ -90,6 +89,7 @@ executables:
     - -with-rtsopts=-N
     dependencies:
     - analytics
+    - squeal-postgresql
 
   analytics-migrations:
     main:                db/Migrations.hs
@@ -99,11 +99,6 @@ executables:
     - -with-rtsopts=-N
     dependencies:
     - analytics
-    - postgresql-simple >= 0.6.2
-    - postgresql-simple-migration >= 0.1.14.0
-    - bytestring >= 0.10.8.2
-
-
 
 tests:
   spec:
@@ -117,10 +112,9 @@ tests:
     - analytics
     - hspec >= 2.7.1
     - hspec-core
-    - postgresql-simple >= 0.4.9.0
-    - postgresql-simple-migration >= 0.1.14.0
     - postgres-options >= 0.1.0.1
-    - tmp-postgres >= 0.3.0.1
-    - string-conversions >= 0.4.0.1
+    - postgresql-simple >= 0.4.9.0
     - persistent >= 2.5
     - protolude >= 0.2
+    - string-conversions >= 0.4.0.1
+    - tmp-postgres >= 0.3.0.1

src/ApiTypes.hs

@@ -2,65 +2,35 @@ module ApiTypes (
     Event(..)
   , PageView(..)
   , UserSession(..)
-  , ToDatabase
-  , convertToDb
 ) where
 
-import           Data.Aeson             (FromJSON, ToJSON)
-import qualified Data.Text              as T
-import           Data.UUID.Types        (UUID)
-import           Database.Beam          as B
-import qualified Database.Beam.Postgres as Pg
-import qualified Database.Beam.Query    as BeamQ
-import           GHC.Generics           (Generic)
-
-------------------------------------------------------
-import           Db                     (EventsDBT (..), PageViewDBT (..),
-                                         UserSessionDBT (..))
-
-class ToDatabase a b where
-  convertToDb :: a -> b
+import           Data.Aeson      (FromJSON, ToJSON)
+import qualified Data.Text       as T
+import           Data.UUID.Types (UUID)
+import qualified Generics.SOP    as SOP
+import qualified GHC.Generics    as GHC
 
 newtype UserSession = UserSession {
   userSessionId :: UUID
-} deriving (Eq, Show, Generic)
+} deriving stock (Eq, Show, GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
 instance ToJSON UserSession
 instance FromJSON UserSession
 
 data Event = Event {
   evUserSessionId :: UUID,
   evCategory      :: T.Text,
   evLabel         :: T.Text
-} deriving (Eq, Show, Generic)
+} deriving (Eq, Show, GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
 instance ToJSON Event
 instance FromJSON Event
 
 data PageView = PageView {
   pgUserSessionId :: UUID,
   pgUrlFilePath   :: T.Text
-} deriving (Eq, Show, Generic)
+} deriving (Eq, Show, GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
 instance ToJSON PageView
 instance FromJSON PageView
 
-
-instance ToDatabase UserSession (UserSessionDBT (BeamQ.QExpr Pg.Postgres s)) where
-  convertToDb _ = UserSessionDB B.default_ Pg.now_
-
-
-instance ToDatabase PageView (PageViewDBT (BeamQ.QExpr Pg.Postgres s)) where
-  convertToDb PageView{..} =
-    PageViewDB
-      B.default_
-      (BeamQ.val_ pgUserSessionId)
-      (BeamQ.val_ pgUrlFilePath)
-      Pg.now_
-
-instance ToDatabase Event (EventsDBT (BeamQ.QExpr Pg.Postgres s)) where
-  convertToDb Event{..} =
-    EventsDB
-      B.default_
-      (BeamQ.val_ evUserSessionId)
-      (BeamQ.val_ evCategory)
-      (BeamQ.val_ evLabel)
-      Pg.now_
-

src/Context.hs

@@ -1,37 +1,52 @@
 module Context (
   Ctx(..)
+  , CtxTest(..)
   , readContextFromEnv
   , readContextFromEnvWithConnStr
 ) where
 
-import qualified Data.ByteString.Char8  as BSC
-import           Data.Maybe             (fromMaybe)
-import qualified Data.Text              as T
-import qualified Database.Beam.Postgres as Pg
-import           System.Environment     (getEnv)
-import           Text.Read              (readMaybe)
-
+import qualified Data.ByteString.Char8 as BSC
+import           Data.Maybe            (fromMaybe)
+import qualified Data.Text             as T
+import           Squeal.PostgreSQL     (Connection, K, Pool,
+                                        createConnectionPool)
+import           Squeal.Schema         (DB)
+import           System.Environment    (getEnv)
+import           Text.Read             (readMaybe)
+import qualified Database.PostgreSQL.Simple as PG
 
 data Ctx = Ctx {
-  conn          :: Pg.Connection,
+  conn          :: Pool (K Connection DB),
   port          :: Int,
   apiKey        :: T.Text,
-  corsReqOrigin :: T.Text
+  corsReqOrigin :: T.Text,
+  connStr       :: BSC.ByteString --for migration
 }
 
+defaultMakePool :: BSC.ByteString ->  IO (Pool (K Connection DB))
+defaultMakePool connStr = createConnectionPool connStr 5 10 10
+
 readContextFromEnv :: IO Ctx
 readContextFromEnv =
   Ctx <$>
-    (BSC.pack <$> getEnv "DBCONN" >>= Pg.connectPostgreSQL) <*>
+    (BSC.pack <$> getEnv "DBCONN" >>= defaultMakePool) <*>
     (fromMaybe (error "Env var PORT must be set") . readMaybe <$> getEnv "PORT") <*>
     (T.pack <$> getEnv "API_KEY") <*>
-    (T.pack <$> getEnv "CORS_ORIGIN")
+    (T.pack <$> getEnv "CORS_ORIGIN") <*>
+    (BSC.pack <$> getEnv "DBCONN")
+
+data CtxTest = CtxTest {
+  connT          :: PG.Connection,
+  portT          :: Int,
+  apiKeyT        :: T.Text,
+  connStrT       :: BSC.ByteString --for migration
+}
 
-readContextFromEnvWithConnStr :: T.Text -> IO Ctx
+readContextFromEnvWithConnStr :: T.Text -> IO CtxTest
 readContextFromEnvWithConnStr conn =
   let connStr = BSC.pack $ T.unpack conn
-  in Ctx <$>
-      Pg.connectPostgreSQL connStr <*>
+  in CtxTest <$>
+      PG.connectPostgreSQL connStr <*>
       (fromMaybe (error "Env var PORT must be set") . readMaybe <$> getEnv "PORT") <*>
       (T.pack <$> getEnv "API_KEY") <*>
-      (T.pack <$> getEnv "CORS_ORIGIN")
+      (BSC.pack <$> getEnv "DBCONN")