From 759bc2885a76de58a762c4c8144c6fcd12acbdb3 Mon Sep 17 00:00:00 2001 From: Adam Wespiser Date: Sat, 4 Jul 2020 02:29:28 -0400 Subject: [PATCH 1/9] clean up --- db/Migrations.hs | 4 +++ package.yaml | 93 ++++++++++++++++++++++-------------------------- src/ApiTypes.hs | 13 ++----- src/Context.hs | 13 ++++--- src/Db.hs | 12 ++----- src/Server.hs | 13 ++++--- src/Types.hs | 41 ++++++++++++++------- stack.yaml | 67 ++++------------------------------ stack.yaml.lock | 31 +++++++++++++--- 9 files changed, 131 insertions(+), 156 deletions(-) diff --git a/db/Migrations.hs b/db/Migrations.hs index 53e6112..84160ce 100644 --- a/db/Migrations.hs +++ b/db/Migrations.hs @@ -1,3 +1,6 @@ + +main = putStrLn "no upgraded yet" +{- import Database.PostgreSQL.Simple (withTransaction) import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), MigrationContext (..), @@ -20,3 +23,4 @@ main = do migrationResult <- withTransaction con $ runMigration $ MigrationContext migrationDir True con print migrationResult +-} diff --git a/package.yaml b/package.yaml index 76510eb..966ebc6 100644 --- a/package.yaml +++ b/package.yaml @@ -14,68 +14,62 @@ extra-source-files: - LICENSE - Procfile -ghc-options: -- -Wall -- -Werror -- -Wcompat -- -Wincomplete-record-updates -- -Wincomplete-uni-patterns -- -Wredundant-constraints -- -Wtype-defaults +#ghc-options: +#- -Wall +#- -Werror +#- -Wcompat +#- -Wincomplete-record-updates +#- -Wincomplete-uni-patterns +#- -Wredundant-constraints +#- -Wtype-defaults default-extensions: +- AllowAmbiguousTypes - BlockArguments -- OverloadedStrings - DataKinds -- TypeOperators - DeriveAnyClass - DeriveGeneric -- TypeApplications -- GADTs - FlexibleContexts - FlexibleInstances -- TypeFamilies -- StandaloneDeriving -- RecordWildCards -- PartialTypeSignatures +- GADTs +- 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 +- OverloadedLabels +- OverloadedStrings +- PartialTypeSignatures +- StandaloneDeriving +- RecordWildCards +- RankNTypes +- 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 - http-client - http-types +- 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 + # - beam-core >= 0.8.0.0 + # - beam-postgres >= 0.4.0.0 library: source-dirs: src @@ -90,6 +84,7 @@ executables: - -with-rtsopts=-N dependencies: - analytics + - squeal-postgresql analytics-migrations: main: db/Migrations.hs @@ -99,11 +94,9 @@ executables: - -with-rtsopts=-N dependencies: - analytics - - postgresql-simple >= 0.6.2 - - postgresql-simple-migration >= 0.1.14.0 - bytestring >= 0.10.8.2 - - + - postgresql-simple >= 0.6.2 + # - postgresql-simple-migration >= 0.1.14.0 tests: spec: @@ -117,10 +110,10 @@ tests: - analytics - hspec >= 2.7.1 - hspec-core + - postgres-options >= 0.1.0.1 - 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 - persistent >= 2.5 - protolude >= 0.2 + - string-conversions >= 0.4.0.1 + - tmp-postgres >= 0.3.0.1 diff --git a/src/ApiTypes.hs b/src/ApiTypes.hs index 2800d46..788fbae 100644 --- a/src/ApiTypes.hs +++ b/src/ApiTypes.hs @@ -2,24 +2,14 @@ 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 newtype UserSession = UserSession { userSessionId :: UUID @@ -42,7 +32,7 @@ data PageView = PageView { instance ToJSON PageView instance FromJSON PageView - +{- instance ToDatabase UserSession (UserSessionDBT (BeamQ.QExpr Pg.Postgres s)) where convertToDb _ = UserSessionDB B.default_ Pg.now_ @@ -63,4 +53,5 @@ instance ToDatabase Event (EventsDBT (BeamQ.QExpr Pg.Postgres s)) where (BeamQ.val_ evCategory) (BeamQ.val_ evLabel) Pg.now_ +-} diff --git a/src/Context.hs b/src/Context.hs index 05bdce0..07d32ec 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -7,22 +7,27 @@ module Context ( 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 Squeal.PostgreSQL +import Squeal.Schema (DB) data Ctx = Ctx { - conn :: Pg.Connection, + conn :: Pool (K Connection DB), port :: Int, apiKey :: T.Text, corsReqOrigin :: T.Text } + +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") @@ -31,7 +36,7 @@ readContextFromEnvWithConnStr :: T.Text -> IO Ctx readContextFromEnvWithConnStr conn = let connStr = BSC.pack $ T.unpack conn in Ctx <$> - Pg.connectPostgreSQL connStr <*> + (defaultMakePool connStr) <*> (fromMaybe (error "Env var PORT must be set") . readMaybe <$> getEnv "PORT") <*> (T.pack <$> getEnv "API_KEY") <*> (T.pack <$> getEnv "CORS_ORIGIN") diff --git a/src/Db.hs b/src/Db.hs index ff59cf6..5d5b60b 100644 --- a/src/Db.hs +++ b/src/Db.hs @@ -1,15 +1,7 @@ module Db ( - PageViewDBT(..) - , PageViewId - , EventsDBT(..) - , EventsId - , UserSessionDBT(..) - , UserSessionId - , AnalyticsDb(..) - , analyticsDb ) where - +{- import GHC.Generics (Generic) import Database.Beam.Schema ( Beamable @@ -91,4 +83,4 @@ analyticsDb = , dbPageView = setEntityName "page_view" , dbUserSession = setEntityName "user_session" } - +-} diff --git a/src/Server.hs b/src/Server.hs index 62cc510..78eebb6 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -22,7 +22,9 @@ import Network.Wai.Handler.Warp (defaultSettings, setBeforeMainLoop, setPort) import Servant -import Servant.API.Generic ((:-), ToServantApi, Generic, genericApi) +import Servant.API.Generic ((:-), Generic, + ToServantApi, + genericApi) import Servant.Server.Generic (AsServerT, genericServeT) @@ -44,6 +46,7 @@ import Types (AppM, getContext, insertUserSession, withAuth) import qualified Utils (headMay) +import qualified Data.UUID.Types as UUID (nil) data Routes route = Routes { event :: route :- "event" @@ -73,21 +76,21 @@ server = Routes withAuth auth $ do Ctx{ conn } <- getContext liftIO $ print evt - insertEvent conn evt + -- insertEvent conn evt return NoContent page :: Maybe T.Text -> PageView -> AppM Ctx NoContent page auth pageview@PageView{..} = withAuth auth $ do Ctx{ conn } <- getContext liftIO $ print pageview - insertPageView conn pageview + -- insertPageView conn pageview return NoContent session :: Maybe T.Text -> AppM Ctx UserSession session auth = withAuth auth $ do Ctx{ conn } <- getContext - status <- insertUserSession conn - return $ UserSession $ (usersessionId . getSingleResult) status + -- status <- insertUserSession conn + return $ UserSession UUID.nil getSingleResult lst = -- TODO code smell: headMay then toss an error? fromMaybe (error $ "storeRun: single item not returned: " ++ show lst ) diff --git a/src/Types.hs b/src/Types.hs index dd04860..ffbdcd6 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -9,26 +9,32 @@ module Types ( , insertEvent , HasContext , getContext + , getPool ) where import ApiTypes (Event (..), PageView (..), - UserSession (..), - convertToDb) + UserSession (..)) import Context (Ctx (..)) import Control.Monad.Extra (ifM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Reader (ReaderT, ask) +import Control.Monad.Reader (MonadReader) import qualified Data.Text as T -import qualified Data.UUID.Types as UUID (nil) +import qualified Data.UUID.Types as UUID (UUID) +{- import Database.Beam as B import Database.Beam.Backend.SQL.BeamExtensions (runInsertReturningList) import qualified Database.Beam.Postgres as Pg -import Db +-} + import Servant -import Servant.Server (err403) +-- import Servant.Server (err403) +import Squeal.Schema (DB) +import Squeal.PostgreSQL + type AppM ctx = ReaderT ctx Handler @@ -45,26 +51,37 @@ instance MonadAuth (AppM Ctx) where Ctx{..} <- getContext pure $ auth' == Just apiKey -class Monad m => HasContext m where +class HasContext m => HasDbConn m where + getPool :: m (Pool (K Connection DB)) +instance HasDbConn (AppM Ctx) where + getPool = conn <$> getContext + +class (MonadReader Ctx m, Monad m) => HasContext m where getContext :: m Ctx instance HasContext (AppM Ctx) where getContext = ask -class Monad m => MonadDb m where - insertUserSession :: Pg.Connection -> m [UserSessionDBT Identity] - fetchUserSession :: Pg.Connection -> m UserSession - insertPageView :: Pg.Connection -> PageView -> m () - insertEvent :: Pg.Connection -> Event -> m () +class (Monad m, HasDbConn m) => MonadDb m where + insertUserSession :: m UUID.UUID + fetchUserSession :: m UserSession + insertPageView :: PageView -> m () + insertEvent :: Event -> m () +instance MonadDb (AppM Ctx) where + insertUserSession = undefined + fetchUserSession = undefined + insertPageView _ = undefined + insertEvent _ = undefined +{- instance MonadDb (AppM Ctx) where insertUserSession conn = liftIO $ Pg.runBeamPostgresDebug putStrLn conn $ do insertValue <- runInsertReturningList $ insert (dbUserSession analyticsDb) $ insertExpressions [UserSessionDB B.default_ Pg.now_] - liftIO $ print insertValue pure insertValue fetchUserSession _ = liftIO $ return $ UserSession UUID.nil insertPageView conn pageview = liftIO $ Pg.runBeamPostgresDebug putStrLn conn $ runInsert $ insert (dbPageView analyticsDb) $ insertExpressions [convertToDb pageview] insertEvent conn event = liftIO $ Pg.runBeamPostgresDebug putStrLn conn $ runInsert $ insert (dbEvents analyticsDb) $ insertExpressions [convertToDb event] +-} diff --git a/stack.yaml b/stack.yaml index a451576..ba7e2a3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,68 +1,15 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ +resolver: lts-15.3 -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-14.22 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai packages: - . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# + extra-deps: - servant-options-0.1.0.0@sha256:39f50166a68006250e79370372f553ca476f14d06d93fa0c401050253aeba803,914 - tmp-postgres-0.3.0.1@sha256:26a8c35aef8e97a6012a75c1c6a75f552d64d3233514e028ab13ceaf89324c06,2695 - postgres-options-0.1.0.1@sha256:42331140b3c2e608c87005bc7636271b53db20fce7fd091cd4341128db3b47ad,960 -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] + - free-categories-0.2.0.0@sha256:2d248c669140cf82324569eaf90406c7c9d4a510088aca1979c9bd411bc5980c,855 + - git: https://github.com/morphismtech/squeal.git + commit: 7557c2ddd32430ed82937a7864e5879b1ac77513 + subdirs: + - squeal-postgresql -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.1" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock index 5fc6c4b..57d1906 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -25,9 +25,32 @@ packages: sha256: 8c958f907817255ee4d72a13b3f4296323a02e55d25bd585c7d68d3a54fc9578 original: hackage: postgres-options-0.1.0.1@sha256:42331140b3c2e608c87005bc7636271b53db20fce7fd091cd4341128db3b47ad,960 +- completed: + hackage: free-categories-0.2.0.0@sha256:2d248c669140cf82324569eaf90406c7c9d4a510088aca1979c9bd411bc5980c,855 + pantry-tree: + size: 521 + sha256: af05c360575925cbb741acfc8daf527ede3b17bf6cc33b25b699821753f545f2 + original: + hackage: free-categories-0.2.0.0@sha256:2d248c669140cf82324569eaf90406c7c9d4a510088aca1979c9bd411bc5980c,855 +- completed: + subdir: squeal-postgresql + cabal-file: + size: 5624 + sha256: 2bd808a80c8c67da612049908152134b5d70650303239c6754ed0cf1dfab5305 + name: squeal-postgresql + version: 0.6.0.2 + git: https://github.com/morphismtech/squeal.git + pantry-tree: + size: 5676 + sha256: 71404c6e9b1c2005edda02ef0ac1dfc43fb9cc80a8ea03f6294aeedde1a6d03b + commit: 7557c2ddd32430ed82937a7864e5879b1ac77513 + original: + subdir: squeal-postgresql + git: https://github.com/morphismtech/squeal.git + commit: 7557c2ddd32430ed82937a7864e5879b1ac77513 snapshots: - completed: - size: 524164 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/22.yaml - sha256: 7ad8f33179b32d204165a3a662c6269464a47a7e65a30abc38d01b5a38ec42c0 - original: lts-14.22 + size: 491373 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/3.yaml + sha256: 29e9ff61b8bf4b4fcff55cde3ac106ebb971f0d21331dccac9eee63374fa6ca8 + original: lts-15.3 From b55ce3bdd03ebb013c4a1e6fc184dd83d06d39d4 Mon Sep 17 00:00:00 2001 From: Adam Wespiser Date: Sun, 5 Jul 2020 00:54:16 -0400 Subject: [PATCH 2/9] WIP: prepare monad stack for squeal --- package.yaml | 4 ++++ src/ApiTypes.hs | 13 +++++++---- src/Server.hs | 34 +++++++++++++++++---------- src/Types.hs | 62 ++++++++++++++++++++++++++++++++++++++++--------- 4 files changed, 86 insertions(+), 27 deletions(-) diff --git a/package.yaml b/package.yaml index 966ebc6..44f2b60 100644 --- a/package.yaml +++ b/package.yaml @@ -29,9 +29,11 @@ default-extensions: - DataKinds - DeriveAnyClass - DeriveGeneric +- DerivingStrategies - FlexibleContexts - FlexibleInstances - GADTs +- GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - NamedFieldPuns @@ -50,6 +52,8 @@ dependencies: - base >= 4.7 - aeson >= 1.4.5.0 - bytestring >= 0.10.8.2 +- exceptions +- generics-sop - http-client - http-types - extra >= 1.6.18 diff --git a/src/ApiTypes.hs b/src/ApiTypes.hs index 788fbae..345decd 100644 --- a/src/ApiTypes.hs +++ b/src/ApiTypes.hs @@ -7,13 +7,16 @@ module ApiTypes ( import Data.Aeson (FromJSON, ToJSON) import qualified Data.Text as T import Data.UUID.Types (UUID) -import GHC.Generics (Generic) +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 @@ -21,14 +24,16 @@ 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 diff --git a/src/Server.hs b/src/Server.hs index 78eebb6..4e5c292 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -7,7 +7,7 @@ module Server ( , runMain ) where -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Reader (runReaderT) import Data.Maybe (fromMaybe) import qualified Data.Text as T @@ -43,10 +43,12 @@ import Db import Types (AppM, getContext, insertEvent, insertPageView, - insertUserSession, - withAuth) + insertUserSession, HasContext,MonadAuth, + withAuth, App, runAppInTransaction) import qualified Utils (headMay) import qualified Data.UUID.Types as UUID (nil) +import Control.Monad ((<=<)) + data Routes route = Routes { event :: route :- "event" @@ -64,28 +66,28 @@ data Routes route = Routes :> Get '[JSON] UserSession } deriving (Generic) -server :: Routes (AsServerT (AppM Ctx)) +server :: Routes (AsServerT App) server = Routes { event , page , session } where - event :: Maybe T.Text -> Event -> AppM Ctx NoContent + event :: (Monad m, HasContext m, MonadIO m, MonadAuth m) => Maybe T.Text -> Event -> m NoContent event auth evt@Event{..} = withAuth auth $ do Ctx{ conn } <- getContext liftIO $ print evt -- insertEvent conn evt return NoContent - page :: Maybe T.Text -> PageView -> AppM Ctx NoContent + page :: (Monad m, HasContext m, MonadIO m, MonadAuth m) => Maybe T.Text -> PageView -> m NoContent page auth pageview@PageView{..} = withAuth auth $ do Ctx{ conn } <- getContext liftIO $ print pageview -- insertPageView conn pageview return NoContent - session :: Maybe T.Text -> AppM Ctx UserSession + session :: (Monad m, HasContext m, MonadIO m, MonadAuth m) => Maybe T.Text -> m UserSession session auth = withAuth auth $ do Ctx{ conn } <- getContext @@ -100,18 +102,26 @@ app :: Ctx -> Application app ctx = logStdoutDev $ cors (const $ Just policy) $ provideOptions apiProxy $ - genericServeT (natTrans ctx) server + genericServeT toHandler server where - apiProxy :: Proxy API - apiProxy = genericApi (Proxy :: Proxy Routes) - policy = simpleCorsResourcePolicy - { corsRequestHeaders = [ "content-type" ] } + apiProxy :: Proxy API + apiProxy = genericApi (Proxy :: Proxy Routes) + policy = simpleCorsResourcePolicy + { corsRequestHeaders = [ "content-type" ] } + toHandler :: App a -> Handler a + toHandler = + either throwError pure + <=< liftIO + . fmap Right + . runAppInTransaction ctx type API = ToServantApi Routes natTrans :: ctx -> AppM ctx a -> Handler a natTrans ctx x = runReaderT x ctx + + runAppWithContext :: Ctx -> IO () runAppWithContext ctx = let settings = setPort (port ctx) $ defaultSettings diff --git a/src/Types.hs b/src/Types.hs index ffbdcd6..357d41a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,5 +1,6 @@ module Types ( AppM + , App , MonadAuth , withAuth , MonadDb @@ -10,6 +11,7 @@ module Types ( , HasContext , getContext , getPool + , runAppInTransaction ) where import ApiTypes (Event (..), @@ -18,10 +20,10 @@ import ApiTypes (Event (..), import Context (Ctx (..)) import Control.Monad.Extra (ifM) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Class (lift, MonadTrans) import Control.Monad.Trans.Except (throwE) -import Control.Monad.Trans.Reader (ReaderT, ask) -import Control.Monad.Reader (MonadReader) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import Control.Monad.Reader (MonadReader, ask) import qualified Data.Text as T import qualified Data.UUID.Types as UUID (UUID) {- @@ -34,31 +36,63 @@ import Servant -- import Servant.Server (err403) import Squeal.Schema (DB) import Squeal.PostgreSQL +import Squeal.Schema +import Squeal.Orphans () +import Control.Monad.IO.Class +import Control.Monad.Catch hiding (Handler) + + +newtype AppT r m a = AppT { unAppT :: ReaderT r m a } + deriving newtype + ( Functor + , Applicative + , Monad + , MonadReader r + , MonadIO + , MonadCatch + , MonadThrow + , MonadMask + ) +type AppT' = AppT Ctx +type App = AppT Ctx (PQ DB DB IO) + +instance MonadTrans (AppT r) where + lift = AppT . lift + type AppM ctx = ReaderT ctx Handler -class (Monad m) => MonadAuth m where + +runApp :: Ctx -> App a -> PQ DB DB IO a +runApp cfg = flip runReaderT cfg . unAppT + +runAppInTransaction :: Ctx -> App a -> IO a +runAppInTransaction ctx = usingConnectionPool (conn ctx) . runApp ctx + + +---------------------------------- +class (Monad m, MonadThrow m, MonadReader Ctx m) => MonadAuth m where withAuth :: Maybe T.Text -> m a -> m a -instance MonadAuth (AppM Ctx) where +instance (schemas ~ DB) => MonadAuth (AppT Ctx (PQ schemas schemas IO)) where withAuth auth f = ifM (isCorrectAuth auth) f - (lift $ Handler $ throwE err403) + (lift $ throwM $ TServerError 403) where - isCorrectAuth :: Maybe T.Text -> AppM Ctx Bool + isCorrectAuth :: (MonadReader Ctx m) => Maybe T.Text -> m Bool isCorrectAuth auth' = do - Ctx{..} <- getContext + Ctx{..} <- ask pure $ auth' == Just apiKey class HasContext m => HasDbConn m where getPool :: m (Pool (K Connection DB)) -instance HasDbConn (AppM Ctx) where +instance (schemas ~ DB) => HasDbConn (AppT Ctx (PQ schemas schemas IO)) where getPool = conn <$> getContext class (MonadReader Ctx m, Monad m) => HasContext m where getContext :: m Ctx -instance HasContext (AppM Ctx) where +instance (schemas ~ DB) => HasContext (AppT Ctx (PQ schemas schemas IO)) where getContext = ask class (Monad m, HasDbConn m) => MonadDb m where @@ -66,12 +100,18 @@ class (Monad m, HasDbConn m) => MonadDb m where fetchUserSession :: m UserSession insertPageView :: PageView -> m () insertEvent :: Event -> m () -instance MonadDb (AppM Ctx) where +instance (schemas ~ DB) => MonadDb (AppT Ctx (PQ schemas schemas IO)) where insertUserSession = undefined fetchUserSession = undefined insertPageView _ = undefined insertEvent _ = undefined + +data MyException = TServerError Integer + deriving Show + +instance Exception MyException + {- instance MonadDb (AppM Ctx) where insertUserSession conn = liftIO $ Pg.runBeamPostgresDebug putStrLn conn $ do From d8f24d97d92964b0e70d31b9253aacf3115379f4 Mon Sep 17 00:00:00 2001 From: Adam Wespiser Date: Sun, 5 Jul 2020 03:58:29 -0400 Subject: [PATCH 3/9] API working with squeal --- package.yaml | 2 +- src/Server.hs | 17 +++++++++-------- src/Types.hs | 9 +++++---- 3 files changed, 15 insertions(+), 13 deletions(-) diff --git a/package.yaml b/package.yaml index 44f2b60..cef6bbc 100644 --- a/package.yaml +++ b/package.yaml @@ -33,7 +33,7 @@ default-extensions: - FlexibleContexts - FlexibleInstances - GADTs -- GeneralizedNewtypeDeriving +- GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - NamedFieldPuns diff --git a/src/Server.hs b/src/Server.hs index 4e5c292..354885f 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -48,6 +48,9 @@ import Types (AppM, getContext, import qualified Utils (headMay) import qualified Data.UUID.Types as UUID (nil) import Control.Monad ((<=<)) +import Squeal.Query (insertEventPq, insertPageViewPq, insertSessionPq) +import qualified Squeal.PostgreSQL as Sq +import Squeal.Schema (DB) data Routes route = Routes { event :: route @@ -73,25 +76,26 @@ server = Routes , session } where - event :: (Monad m, HasContext m, MonadIO m, MonadAuth m) => Maybe T.Text -> Event -> m NoContent + event :: (Monad m, HasContext m, MonadIO m, MonadAuth m, Sq.MonadPQ DB m) => Maybe T.Text -> Event -> m NoContent event auth evt@Event{..} = withAuth auth $ do Ctx{ conn } <- getContext liftIO $ print evt - -- insertEvent conn evt + Sq.executeParams insertEventPq evt return NoContent - page :: (Monad m, HasContext m, MonadIO m, MonadAuth m) => Maybe T.Text -> PageView -> m NoContent + page :: (Monad m, HasContext m, MonadIO m, MonadAuth m, Sq.MonadPQ DB m) => Maybe T.Text -> PageView -> m NoContent page auth pageview@PageView{..} = withAuth auth $ do Ctx{ conn } <- getContext liftIO $ print pageview - -- insertPageView conn pageview + Sq.executeParams insertPageViewPq pageview return NoContent - session :: (Monad m, HasContext m, MonadIO m, MonadAuth m) => Maybe T.Text -> m UserSession + session :: (Monad m, HasContext m, MonadIO m, MonadAuth m, Sq.MonadPQ DB m) => Maybe T.Text -> m UserSession session auth = withAuth auth $ do Ctx{ conn } <- getContext -- status <- insertUserSession conn + Sq.execute insertSessionPq return $ UserSession UUID.nil getSingleResult lst = -- TODO code smell: headMay then toss an error? @@ -120,8 +124,6 @@ type API = ToServantApi Routes natTrans :: ctx -> AppM ctx a -> Handler a natTrans ctx x = runReaderT x ctx - - runAppWithContext :: Ctx -> IO () runAppWithContext ctx = let settings = setPort (port ctx) $ defaultSettings @@ -135,4 +137,3 @@ runMain = do setBeforeMainLoop (hPutStrLn stderr ("listening on port " ++ show (port ctx))) $ defaultSettings runSettings settings (app ctx) - diff --git a/src/Types.hs b/src/Types.hs index 357d41a..3577ab8 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} module Types ( AppM , App @@ -59,17 +60,18 @@ type App = AppT Ctx (PQ DB DB IO) instance MonadTrans (AppT r) where lift = AppT . lift - - type AppM ctx = ReaderT ctx Handler - runApp :: Ctx -> App a -> PQ DB DB IO a runApp cfg = flip runReaderT cfg . unAppT runAppInTransaction :: Ctx -> App a -> IO a runAppInTransaction ctx = usingConnectionPool (conn ctx) . runApp ctx +instance (schemas ~ DB, MonadPQ schemas m) => MonadPQ schemas (AppT r m) where + executeParams q = lift . executeParams q + executePrepared q = lift . executePrepared q + executePrepared_ q = lift . executePrepared_ q ---------------------------------- class (Monad m, MonadThrow m, MonadReader Ctx m) => MonadAuth m where @@ -109,7 +111,6 @@ instance (schemas ~ DB) => MonadDb (AppT Ctx (PQ schemas schemas IO)) where data MyException = TServerError Integer deriving Show - instance Exception MyException {- From 678816fb22b8e580bcf83f1245b50169542600c2 Mon Sep 17 00:00:00 2001 From: Adam Wespiser Date: Sun, 5 Jul 2020 16:04:05 -0400 Subject: [PATCH 4/9] emnd --- src/Types.hs | 19 +------------------ 1 file changed, 1 insertion(+), 18 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index 3577ab8..9bc64f5 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -80,7 +80,7 @@ class (Monad m, MonadThrow m, MonadReader Ctx m) => MonadAuth m where instance (schemas ~ DB) => MonadAuth (AppT Ctx (PQ schemas schemas IO)) where withAuth auth f = ifM (isCorrectAuth auth) f - (lift $ throwM $ TServerError 403) + (lift $ throwM $ err403) where isCorrectAuth :: (MonadReader Ctx m) => Maybe T.Text -> m Bool isCorrectAuth auth' = do @@ -109,20 +109,3 @@ instance (schemas ~ DB) => MonadDb (AppT Ctx (PQ schemas schemas IO)) where insertEvent _ = undefined -data MyException = TServerError Integer - deriving Show -instance Exception MyException - -{- -instance MonadDb (AppM Ctx) where - insertUserSession conn = liftIO $ Pg.runBeamPostgresDebug putStrLn conn $ do - insertValue <- - runInsertReturningList $ insert (dbUserSession analyticsDb) $ insertExpressions [UserSessionDB B.default_ Pg.now_] - pure insertValue - fetchUserSession _ = liftIO $ return $ UserSession UUID.nil - insertPageView conn pageview = liftIO $ Pg.runBeamPostgresDebug putStrLn conn $ runInsert $ - insert (dbPageView analyticsDb) $ insertExpressions [convertToDb pageview] - insertEvent conn event = liftIO $ Pg.runBeamPostgresDebug putStrLn conn $ runInsert $ - insert (dbEvents analyticsDb) $ insertExpressions [convertToDb event] --} - From 9f5b7b1b574833af7947acaedecb0e93a3a2fe16 Mon Sep 17 00:00:00 2001 From: Adam Wespiser Date: Sun, 5 Jul 2020 16:27:02 -0400 Subject: [PATCH 5/9] Exe clean up and stylish-haskell --- src/ApiTypes.hs | 36 +++------------------ src/Context.hs | 14 ++++---- src/Db.hs | 86 ------------------------------------------------- src/Server.hs | 58 +++++++++++++++++++-------------- src/Types.hs | 74 +++++++++++++----------------------------- src/Utils.hs | 11 +++---- 6 files changed, 71 insertions(+), 208 deletions(-) delete mode 100644 src/Db.hs diff --git a/src/ApiTypes.hs b/src/ApiTypes.hs index 345decd..f72e44a 100644 --- a/src/ApiTypes.hs +++ b/src/ApiTypes.hs @@ -4,19 +4,16 @@ module ApiTypes ( , UserSession(..) ) where -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 - ------------------------------------------------------- +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 stock (Eq, Show, GHC.Generic) deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - instance ToJSON UserSession instance FromJSON UserSession @@ -37,26 +34,3 @@ data PageView = PageView { 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_ --} - diff --git a/src/Context.hs b/src/Context.hs index 07d32ec..31ba90e 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -4,14 +4,13 @@ module Context ( , readContextFromEnvWithConnStr ) where -import qualified Data.ByteString.Char8 as BSC -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -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 -import Squeal.Schema (DB) - +import Squeal.Schema (DB) +import System.Environment (getEnv) +import Text.Read (readMaybe) data Ctx = Ctx { conn :: Pool (K Connection DB), @@ -20,7 +19,6 @@ data Ctx = Ctx { corsReqOrigin :: T.Text } - defaultMakePool :: BSC.ByteString -> IO (Pool (K Connection DB)) defaultMakePool connStr = createConnectionPool connStr 5 10 10 diff --git a/src/Db.hs b/src/Db.hs deleted file mode 100644 index 5d5b60b..0000000 --- a/src/Db.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Db - ( - ) where -{- -import GHC.Generics (Generic) -import Database.Beam.Schema ( - Beamable - , Columnar - , C - , dbModification - , defaultDbSettings - , Database - , DatabaseSettings - , PrimaryKey - , primaryKey - , Table - , TableEntity - , withDbModification - , setEntityName - ) -import Data.Functor.Identity (Identity) -import qualified Data.Text as T -import Data.Time.LocalTime (LocalTime) -import Database.Beam.Backend.SQL.BeamExtensions (SqlSerial) -import Data.UUID.Types (UUID) - - -data UserSessionDBT f = UserSessionDB { - usersessionId :: C f UUID, - usersessionModtime :: C f LocalTime -} deriving (Generic) -instance Beamable UserSessionDBT -type UserSessionDB = UserSessionDBT Identity -type UserSessionId = PrimaryKey UserSessionDBT Identity -instance Table UserSessionDBT where - data PrimaryKey UserSessionDBT f = UserSessionId (Columnar f UUID) - deriving (Generic, Beamable) - primaryKey = UserSessionId . usersessionId -deriving instance Show UserSessionDB - -data EventsDBT f = EventsDB { - eventsId :: C f (SqlSerial Int), - eventsUserSessionId :: C f UUID, - eventsCategory :: C f T.Text, - eventsLabel :: C f T.Text, - eventsModtime :: C f LocalTime -} deriving Generic -instance Beamable EventsDBT -type EventsDB = EventsDBT Identity -type EventsId = PrimaryKey EventsDBT Identity -instance Table EventsDBT where - data PrimaryKey EventsDBT f = EventsId (Columnar f (SqlSerial Int)) - deriving (Generic, Beamable) - primaryKey = EventsId . eventsId -deriving instance Show EventsDB - - -data PageViewDBT f = PageViewDB { - pageviewId :: C f (SqlSerial Int), - pageviewUserSessionId :: C f UUID, - pageviewUrlFilepath :: C f T.Text, - pageviewModtime :: C f LocalTime -} deriving (Generic, Beamable) -type PageViewDB = PageViewDBT Identity -type PageViewId = PrimaryKey PageViewDBT Identity -instance Table PageViewDBT where - data PrimaryKey PageViewDBT f = PageViewId (Columnar f (SqlSerial Int)) - deriving (Generic, Beamable) - primaryKey = PageViewId . pageviewId -deriving instance Show PageViewDB - -data AnalyticsDb f = AnalyticsDb { - dbEvents :: f (TableEntity EventsDBT), - dbPageView :: f (TableEntity PageViewDBT), - dbUserSession :: f (TableEntity UserSessionDBT) -} deriving (Generic, Database be) - -analyticsDb :: DatabaseSettings be AnalyticsDb -analyticsDb = - defaultDbSettings `withDbModification` - dbModification { - dbEvents = setEntityName "events" - , dbPageView = setEntityName "page_view" - , dbUserSession = setEntityName "user_session" - } --} diff --git a/src/Server.hs b/src/Server.hs index 354885f..0484cef 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -7,7 +7,7 @@ module Server ( , runMain ) where -import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Reader (runReaderT) import Data.Maybe (fromMaybe) import qualified Data.Text as T @@ -39,18 +39,18 @@ import ApiTypes (Event (..), UserSession (..)) import Context (Ctx (..), readContextFromEnv) -import Db -import Types (AppM, getContext, - insertEvent, - insertPageView, - insertUserSession, HasContext,MonadAuth, - withAuth, App, runAppInTransaction) +import Control.Monad ((<=<)) +import qualified Data.UUID.Types as UUID (nil) +import qualified Squeal.PostgreSQL as Sq +import Squeal.Query (insertEventPq, + insertPageViewPq, + insertSessionPq) +import Squeal.Schema (DB) +import Types (App, HasContext, + MonadAuth, getContext, + runAppInTransaction, + withAuth) import qualified Utils (headMay) -import qualified Data.UUID.Types as UUID (nil) -import Control.Monad ((<=<)) -import Squeal.Query (insertEventPq, insertPageViewPq, insertSessionPq) -import qualified Squeal.PostgreSQL as Sq -import Squeal.Schema (DB) data Routes route = Routes { event :: route @@ -76,31 +76,42 @@ server = Routes , session } where - event :: (Monad m, HasContext m, MonadIO m, MonadAuth m, Sq.MonadPQ DB m) => Maybe T.Text -> Event -> m NoContent + event :: + ( Monad m + , MonadIO m + , HasContext m + , MonadAuth m + , Sq.MonadPQ DB m) + => Maybe T.Text -> Event -> m NoContent event auth evt@Event{..} = withAuth auth $ do Ctx{ conn } <- getContext - liftIO $ print evt Sq.executeParams insertEventPq evt return NoContent - page :: (Monad m, HasContext m, MonadIO m, MonadAuth m, Sq.MonadPQ DB m) => Maybe T.Text -> PageView -> m NoContent + page :: + ( Monad m + , MonadIO m + , HasContext m + , MonadAuth m + , Sq.MonadPQ DB m) + => Maybe T.Text -> PageView -> m NoContent page auth pageview@PageView{..} = withAuth auth $ do Ctx{ conn } <- getContext - liftIO $ print pageview Sq.executeParams insertPageViewPq pageview return NoContent - session :: (Monad m, HasContext m, MonadIO m, MonadAuth m, Sq.MonadPQ DB m) => Maybe T.Text -> m UserSession + session :: + ( Monad m + , MonadIO m + , HasContext m + , MonadAuth m + , Sq.MonadPQ DB m) + => Maybe T.Text -> m UserSession session auth = withAuth auth $ do Ctx{ conn } <- getContext - -- status <- insertUserSession conn Sq.execute insertSessionPq return $ UserSession UUID.nil - getSingleResult lst = - -- TODO code smell: headMay then toss an error? - fromMaybe (error $ "storeRun: single item not returned: " ++ show lst ) - $ Utils.headMay lst app :: Ctx -> Application app ctx = logStdoutDev $ @@ -121,9 +132,6 @@ app ctx = logStdoutDev $ type API = ToServantApi Routes -natTrans :: ctx -> AppM ctx a -> Handler a -natTrans ctx x = runReaderT x ctx - runAppWithContext :: Ctx -> IO () runAppWithContext ctx = let settings = setPort (port ctx) $ defaultSettings diff --git a/src/Types.hs b/src/Types.hs index 9bc64f5..d8921dc 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,46 +1,32 @@ {-# LANGUAGE UndecidableInstances #-} module Types ( - AppM - , App + App , MonadAuth , withAuth - , MonadDb - , insertUserSession - , fetchUserSession - , insertPageView - , insertEvent , HasContext , getContext , getPool , runAppInTransaction ) where -import ApiTypes (Event (..), - PageView (..), - UserSession (..)) -import Context (Ctx (..)) -import Control.Monad.Extra (ifM) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift, MonadTrans) -import Control.Monad.Trans.Except (throwE) -import Control.Monad.Trans.Reader (ReaderT, runReaderT) -import Control.Monad.Reader (MonadReader, ask) -import qualified Data.Text as T -import qualified Data.UUID.Types as UUID (UUID) -{- -import Database.Beam as B -import Database.Beam.Backend.SQL.BeamExtensions (runInsertReturningList) -import qualified Database.Beam.Postgres as Pg --} - +import ApiTypes (Event (..), PageView (..), + UserSession (..)) +import Context (Ctx (..)) +import Control.Monad.Catch hiding (Handler) +import Control.Monad.Extra (ifM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.Trans.Except (throwE) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import qualified Data.Text as T +import qualified Data.UUID.Types as UUID (UUID) import Servant --- import Servant.Server (err403) -import Squeal.Schema (DB) -import Squeal.PostgreSQL -import Squeal.Schema -import Squeal.Orphans () -import Control.Monad.IO.Class -import Control.Monad.Catch hiding (Handler) +import Squeal.Orphans () +import Squeal.PostgreSQL +import Squeal.Schema (DB) +import Squeal.Schema newtype AppT r m a = AppT { unAppT :: ReaderT r m a } @@ -60,20 +46,17 @@ type App = AppT Ctx (PQ DB DB IO) instance MonadTrans (AppT r) where lift = AppT . lift -type AppM ctx = ReaderT ctx Handler - -runApp :: Ctx -> App a -> PQ DB DB IO a -runApp cfg = flip runReaderT cfg . unAppT - runAppInTransaction :: Ctx -> App a -> IO a runAppInTransaction ctx = usingConnectionPool (conn ctx) . runApp ctx + where + runApp :: Ctx -> App a -> PQ DB DB IO a + runApp cfg = flip runReaderT cfg . unAppT instance (schemas ~ DB, MonadPQ schemas m) => MonadPQ schemas (AppT r m) where executeParams q = lift . executeParams q executePrepared q = lift . executePrepared q executePrepared_ q = lift . executePrepared_ q ----------------------------------- class (Monad m, MonadThrow m, MonadReader Ctx m) => MonadAuth m where withAuth :: Maybe T.Text -> m a -> m a @@ -82,7 +65,7 @@ instance (schemas ~ DB) => MonadAuth (AppT Ctx (PQ schemas schemas IO)) where ifM (isCorrectAuth auth) f (lift $ throwM $ err403) where - isCorrectAuth :: (MonadReader Ctx m) => Maybe T.Text -> m Bool + isCorrectAuth :: HasContext m => Maybe T.Text -> m Bool isCorrectAuth auth' = do Ctx{..} <- ask pure $ auth' == Just apiKey @@ -96,16 +79,3 @@ class (MonadReader Ctx m, Monad m) => HasContext m where getContext :: m Ctx instance (schemas ~ DB) => HasContext (AppT Ctx (PQ schemas schemas IO)) where getContext = ask - -class (Monad m, HasDbConn m) => MonadDb m where - insertUserSession :: m UUID.UUID - fetchUserSession :: m UserSession - insertPageView :: PageView -> m () - insertEvent :: Event -> m () -instance (schemas ~ DB) => MonadDb (AppT Ctx (PQ schemas schemas IO)) where - insertUserSession = undefined - fetchUserSession = undefined - insertPageView _ = undefined - insertEvent _ = undefined - - diff --git a/src/Utils.hs b/src/Utils.hs index f231643..22f6407 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,14 +1,14 @@ +{-| Description: +The purpose of the module is to repro simple functions +so we can golf down our dependencies, and store common +functions + -} module Utils ( isLeft , isRight , headMay ) where - --- The purpose of the module is to repro simple functions --- so we can golf down our dependencies, and store common --- functions - isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft _ = False @@ -16,7 +16,6 @@ isLeft _ = False isRight :: Either a b -> Bool isRight = not . isLeft --- headMay, borrowed from Protolude headMay :: [a] -> Maybe a headMay = Prelude.foldr (\x _ -> Just x) Nothing From 81232fcf83748f8f5139b4b12aea299992ea248a Mon Sep 17 00:00:00 2001 From: Adam Wespiser Date: Sun, 5 Jul 2020 18:12:11 -0400 Subject: [PATCH 6/9] add in all the Squeal stuff --- db/Migrations.hs | 6 +++++- src/Squeal/Migration/V1.hs | 27 +++++++++++++++++++++++++++ src/Squeal/Orphans.hs | 30 ++++++++++++++++++++++++++++++ src/Squeal/Query.hs | 27 +++++++++++++++++++++++++++ src/Squeal/Schema.hs | 35 +++++++++++++++++++++++++++++++++++ 5 files changed, 124 insertions(+), 1 deletion(-) create mode 100644 src/Squeal/Migration/V1.hs create mode 100644 src/Squeal/Orphans.hs create mode 100644 src/Squeal/Query.hs create mode 100644 src/Squeal/Schema.hs diff --git a/db/Migrations.hs b/db/Migrations.hs index 84160ce..497ef56 100644 --- a/db/Migrations.hs +++ b/db/Migrations.hs @@ -1,5 +1,9 @@ +import Squeal.PostgreSQL +import Squeal.Schema +import Squeal.Migration.V1 (initMigration) -main = putStrLn "no upgraded yet" + +main = printSQL initMigration {- import Database.PostgreSQL.Simple (withTransaction) import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), diff --git a/src/Squeal/Migration/V1.hs b/src/Squeal/Migration/V1.hs new file mode 100644 index 0000000..39f4d4c --- /dev/null +++ b/src/Squeal/Migration/V1.hs @@ -0,0 +1,27 @@ +module Squeal.Migration.V1 where + +import Squeal.PostgreSQL +import Squeal.Schema + + +initMigration :: Definition (Public '[]) DB +initMigration = createTable #events + ( serial `as` #id :* + (uuid & notNullable) `as` #user_session_id :* + (text & notNullable) `as` #category :* + (text & notNullable) `as` #text :* + ((default_ (UnsafeExpression "current_timestamp") (notNullable timestamptz) `as` #modtime)) + ) + ( primaryKey #id `as` #pk_events ) >>> + createTable #page_view + ( serial `as` #id :* + (uuid & notNullable) `as` #user_session_id :* + (text & notNullable) `as` #url_filepath :* + ((default_ (UnsafeExpression "current_timestamp") (notNullable timestamptz) `as` #modtime)) + ) + ( primaryKey #id `as` #pk_page_view ) >>> + createTable #user_session + ((default_ (UnsafeExpression "md5(random()::text || clock_timestamp()::text)::uuid") (notNullable uuid) `as` #id) :* + ((default_ (UnsafeExpression "current_timestamp") (notNullable timestamptz) `as` #modtime)) + ) + ( primaryKey #id `as` #pk_user_session ) diff --git a/src/Squeal/Orphans.hs b/src/Squeal/Orphans.hs new file mode 100644 index 0000000..6d4f96b --- /dev/null +++ b/src/Squeal/Orphans.hs @@ -0,0 +1,30 @@ +module Squeal.Orphans where + +import Control.Monad.Catch (MonadCatch (..), MonadMask (..), + MonadThrow (..)) +import Control.Monad.Trans.Class (lift) +import Squeal.PostgreSQL + + +instance (MonadThrow m, db0 ~ db1) + => MonadThrow (PQ db0 db1 m) where + throwM = lift . throwM + +instance (MonadCatch m, db0 ~ db1) + => MonadCatch (PQ db0 db1 m) where + catch (PQ m) f = PQ $ \k -> m k `catch` \e -> unPQ (f e) k + +instance (MonadMask m, db0 ~ db1) + => MonadMask (PQ db0 db1 m) where + mask a = PQ $ \e -> mask $ \u -> unPQ (a $ q u) e + where q u (PQ b) = PQ (u . b) + uninterruptibleMask a = + PQ $ \k -> uninterruptibleMask $ \u -> unPQ (a $ q u) k + where q u (PQ b) = PQ (u . b) + + generalBracket acquire release use = PQ $ \k -> + K <$> generalBracket + (unK <$> unPQ acquire k) + (\resource exitCase -> unK <$> unPQ (release resource exitCase) k) + (\resource -> unK <$> unPQ (use resource) k) + diff --git a/src/Squeal/Query.hs b/src/Squeal/Query.hs new file mode 100644 index 0000000..70595d1 --- /dev/null +++ b/src/Squeal/Query.hs @@ -0,0 +1,27 @@ +module Squeal.Query where + +import ApiTypes +import Squeal.PostgreSQL +import Squeal.Schema + +insertEventPq :: Statement DB Event () +insertEventPq = manipulation $ insertInto_ #events $ Values_ $ + Default `as` #id :* + Set (param @1) `as` #user_session_id :* + Set (param @2) `as` #category :* + Set (param @3) `as` #text :* + Default `as` #modtime + +insertPageViewPq :: Statement DB PageView () +insertPageViewPq = manipulation $ insertInto_ #page_view $ Values_ $ + Default `as` #id :* + Set (param @1) `as` #user_session_id :* + Set (param @2) `as` #url_filepath :* + Default `as` #modtime + +insertSessionPq :: Statement DB () UserSession +insertSessionPq = Manipulation nilParams genericRow $ + insertInto #user_session + (Values_ (Default `as` #id :* Default `as` #modtime)) + OnConflictDoRaise + (Returning_ (#id `as` #userSessionId)) diff --git a/src/Squeal/Schema.hs b/src/Squeal/Schema.hs new file mode 100644 index 0000000..f2f26e5 --- /dev/null +++ b/src/Squeal/Schema.hs @@ -0,0 +1,35 @@ + +module Squeal.Schema where + +import Squeal.PostgreSQL + +type EventsTable = + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "user_session_id" ::: 'NoDef :=> 'NotNull 'PGuuid + , "category" ::: 'NoDef :=> 'NotNull 'PGtext + , "text" ::: 'NoDef :=> 'NotNull 'PGtext + , "modtime" ::: 'Def :=> 'NotNull 'PGtimestamptz + ] +type EventConstraints = '[ "pk_events" ::: 'PrimaryKey '["id"]] + +type PageViewTable = + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "user_session_id" ::: 'NoDef :=> 'NotNull 'PGuuid + , "url_filepath" ::: 'NoDef :=> 'NotNull 'PGtext + , "modtime" ::: 'Def :=> 'NotNull 'PGtimestamptz + ] +type PageViewConstraints = '["pk_page_view" ::: 'PrimaryKey '["id"]] + +type UserSessionTable = + '[ "id" ::: 'Def :=> 'NotNull 'PGuuid + , "modtime" ::: 'Def :=> 'NotNull 'PGtimestamptz + ] +type UserSessionConstraints = '["pk_user_session" ::: 'PrimaryKey '["id"]] + +type Schema = + '[ "events" ::: 'Table (EventConstraints :=> EventsTable) + , "page_view" ::: 'Table (PageViewConstraints :=> PageViewTable) + , "user_session" ::: 'Table (UserSessionConstraints :=> UserSessionTable) + ] + +type DB = Public Schema From 15b46ebaced117d09bdd774de59c9fad2aad8cf8 Mon Sep 17 00:00:00 2001 From: Adam Wespiser Date: Sun, 5 Jul 2020 19:25:55 -0400 Subject: [PATCH 7/9] update .gitignore --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index b486d88..6d1107d 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,6 @@ analytics.cabal .DS_Store *~ +tags +dist-newstyle/ +hie.yaml From 33d13a7c7569e0b80642a392a15a6a3737029808 Mon Sep 17 00:00:00 2001 From: Adam Wespiser Date: Sun, 5 Jul 2020 19:43:21 -0400 Subject: [PATCH 8/9] add simple migraiton (no error/success control --- db/Migrations.hs | 26 +++++--------------------- src/Context.hs | 9 ++++++--- src/Squeal/Migration/V1.hs | 5 ++++- 3 files changed, 15 insertions(+), 25 deletions(-) diff --git a/db/Migrations.hs b/db/Migrations.hs index 497ef56..be0c421 100644 --- a/db/Migrations.hs +++ b/db/Migrations.hs @@ -1,30 +1,14 @@ +import Context (Ctx (..),conn, readContextFromEnv) import Squeal.PostgreSQL import Squeal.Schema import Squeal.Migration.V1 (initMigration) - -main = printSQL initMigration {- -import Database.PostgreSQL.Simple (withTransaction) -import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), - MigrationContext (..), - MigrationResult (..), - runMigration) -import Context (Ctx (..), - readContextFromEnv) + 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 diff --git a/src/Context.hs b/src/Context.hs index 31ba90e..8e2cd54 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -16,7 +16,8 @@ data Ctx = Ctx { 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)) @@ -28,7 +29,8 @@ readContextFromEnv = (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") readContextFromEnvWithConnStr :: T.Text -> IO Ctx readContextFromEnvWithConnStr conn = @@ -37,4 +39,5 @@ readContextFromEnvWithConnStr conn = (defaultMakePool connStr) <*> (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") diff --git a/src/Squeal/Migration/V1.hs b/src/Squeal/Migration/V1.hs index 39f4d4c..2359812 100644 --- a/src/Squeal/Migration/V1.hs +++ b/src/Squeal/Migration/V1.hs @@ -5,7 +5,8 @@ import Squeal.Schema initMigration :: Definition (Public '[]) DB -initMigration = createTable #events +initMigration = dropTableIfExists #events >>> + createTable #events ( serial `as` #id :* (uuid & notNullable) `as` #user_session_id :* (text & notNullable) `as` #category :* @@ -13,6 +14,7 @@ initMigration = createTable #events ((default_ (UnsafeExpression "current_timestamp") (notNullable timestamptz) `as` #modtime)) ) ( primaryKey #id `as` #pk_events ) >>> + dropTableIfExists #page_view >>> createTable #page_view ( serial `as` #id :* (uuid & notNullable) `as` #user_session_id :* @@ -20,6 +22,7 @@ initMigration = createTable #events ((default_ (UnsafeExpression "current_timestamp") (notNullable timestamptz) `as` #modtime)) ) ( primaryKey #id `as` #pk_page_view ) >>> + dropTableIfExists #user_session >>> createTable #user_session ((default_ (UnsafeExpression "md5(random()::text || clock_timestamp()::text)::uuid") (notNullable uuid) `as` #id) :* ((default_ (UnsafeExpression "current_timestamp") (notNullable timestamptz) `as` #modtime)) From 6c78cb552db5acd74d30605a7e3967ad38e41cb4 Mon Sep 17 00:00:00 2001 From: Adam Wespiser Date: Mon, 10 Aug 2020 00:58:14 -0400 Subject: [PATCH 9/9] adding in unchecked in files --- db/Migrations.hs | 4 +-- package.yaml | 25 ++++++------- src/Context.hs | 19 +++++++--- src/Server.hs | 31 +++++----------- src/Squeal/Migration/V1.hs | 2 ++ src/Squeal/Orphans.hs | 4 ++- src/Squeal/Query.hs | 11 ++++-- src/Squeal/Schema.hs | 5 ++- src/Types.hs | 7 ---- src/Utils.hs | 5 --- test/AnalyticsRouteSpec.hs | 14 ++++---- test/Helpers.hs | 73 ++++++++++++++++++++------------------ 12 files changed, 96 insertions(+), 104 deletions(-) diff --git a/db/Migrations.hs b/db/Migrations.hs index be0c421..f065aaa 100644 --- a/db/Migrations.hs +++ b/db/Migrations.hs @@ -1,6 +1,5 @@ -import Context (Ctx (..),conn, readContextFromEnv) +import Context (connStr, readContextFromEnv) import Squeal.PostgreSQL -import Squeal.Schema import Squeal.Migration.V1 (initMigration) {- @@ -9,6 +8,5 @@ import Squeal.Migration.V1 (initMigration) main :: IO () main = do ctx <- readContextFromEnv - let con = conn ctx withConnection (connStr ctx) $ define initMigration diff --git a/package.yaml b/package.yaml index cef6bbc..3225b4c 100644 --- a/package.yaml +++ b/package.yaml @@ -14,14 +14,14 @@ extra-source-files: - LICENSE - Procfile -#ghc-options: -#- -Wall -#- -Werror -#- -Wcompat -#- -Wincomplete-record-updates -#- -Wincomplete-uni-patterns -#- -Wredundant-constraints -#- -Wtype-defaults +ghc-options: +- -Wall +- -Werror +- -Wcompat +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wredundant-constraints +- -Wtype-defaults default-extensions: - AllowAmbiguousTypes @@ -41,9 +41,11 @@ default-extensions: - OverloadedLabels - OverloadedStrings - PartialTypeSignatures +- PatternSynonyms - StandaloneDeriving - RecordWildCards - RankNTypes +- ScopedTypeVariables - TypeOperators - TypeApplications - TypeFamilies @@ -56,6 +58,7 @@ dependencies: - generics-sop - http-client - http-types +- postgresql-simple - extra >= 1.6.18 - mtl >= 2.2.2 - safe >= 0.3.17 @@ -72,8 +75,6 @@ dependencies: - wai-cors >= 0.2.7 - wai-extra >= 3.0.28 - warp >= 3.2.28 - # - beam-core >= 0.8.0.0 - # - beam-postgres >= 0.4.0.0 library: source-dirs: src @@ -98,9 +99,6 @@ executables: - -with-rtsopts=-N dependencies: - analytics - - bytestring >= 0.10.8.2 - - postgresql-simple >= 0.6.2 - # - postgresql-simple-migration >= 0.1.14.0 tests: spec: @@ -116,7 +114,6 @@ tests: - hspec-core - postgres-options >= 0.1.0.1 - postgresql-simple >= 0.4.9.0 - - postgresql-simple-migration >= 0.1.14.0 - persistent >= 2.5 - protolude >= 0.2 - string-conversions >= 0.4.0.1 diff --git a/src/Context.hs b/src/Context.hs index 8e2cd54..d44092c 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,5 +1,6 @@ module Context ( Ctx(..) + , CtxTest(..) , readContextFromEnv , readContextFromEnvWithConnStr ) where @@ -7,10 +8,12 @@ module Context ( import qualified Data.ByteString.Char8 as BSC import Data.Maybe (fromMaybe) import qualified Data.Text as T -import Squeal.PostgreSQL +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 :: Pool (K Connection DB), @@ -32,12 +35,18 @@ readContextFromEnv = (T.pack <$> getEnv "CORS_ORIGIN") <*> (BSC.pack <$> getEnv "DBCONN") -readContextFromEnvWithConnStr :: T.Text -> IO Ctx +data CtxTest = CtxTest { + connT :: PG.Connection, + portT :: Int, + apiKeyT :: T.Text, + connStrT :: BSC.ByteString --for migration +} + +readContextFromEnvWithConnStr :: T.Text -> IO CtxTest readContextFromEnvWithConnStr conn = let connStr = BSC.pack $ T.unpack conn - in Ctx <$> - (defaultMakePool 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") diff --git a/src/Server.hs b/src/Server.hs index 0484cef..0623135 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -7,9 +7,8 @@ module Server ( , runMain ) where +import Control.Monad ((<=<)) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Reader (runReaderT) -import Data.Maybe (fromMaybe) import qualified Data.Text as T import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, @@ -39,18 +38,14 @@ import ApiTypes (Event (..), UserSession (..)) import Context (Ctx (..), readContextFromEnv) -import Control.Monad ((<=<)) -import qualified Data.UUID.Types as UUID (nil) import qualified Squeal.PostgreSQL as Sq import Squeal.Query (insertEventPq, insertPageViewPq, insertSessionPq) import Squeal.Schema (DB) -import Types (App, HasContext, - MonadAuth, getContext, +import Types (App, MonadAuth, runAppInTransaction, withAuth) -import qualified Utils (headMay) data Routes route = Routes { event :: route @@ -77,41 +72,31 @@ server = Routes } where event :: - ( Monad m - , MonadIO m - , HasContext m + ( MonadIO m , MonadAuth m , Sq.MonadPQ DB m) => Maybe T.Text -> Event -> m NoContent event auth evt@Event{..} = withAuth auth $ do - Ctx{ conn } <- getContext - Sq.executeParams insertEventPq evt + Sq.executeParams_ insertEventPq evt return NoContent page :: - ( Monad m - , MonadIO m - , HasContext m + ( MonadIO m , MonadAuth m , Sq.MonadPQ DB m) => Maybe T.Text -> PageView -> m NoContent page auth pageview@PageView{..} = withAuth auth $ do - Ctx{ conn } <- getContext - Sq.executeParams insertPageViewPq pageview + Sq.executeParams_ insertPageViewPq pageview return NoContent session :: - ( Monad m - , MonadIO m - , HasContext m + ( MonadIO m , MonadAuth m , Sq.MonadPQ DB m) => Maybe T.Text -> m UserSession session auth = withAuth auth $ do - Ctx{ conn } <- getContext - Sq.execute insertSessionPq - return $ UserSession UUID.nil + Sq.execute insertSessionPq >>= Sq.getRow 0 app :: Ctx -> Application app ctx = logStdoutDev $ diff --git a/src/Squeal/Migration/V1.hs b/src/Squeal/Migration/V1.hs index 2359812..94f8f5f 100644 --- a/src/Squeal/Migration/V1.hs +++ b/src/Squeal/Migration/V1.hs @@ -28,3 +28,5 @@ initMigration = dropTableIfExists #events >>> ((default_ (UnsafeExpression "current_timestamp") (notNullable timestamptz) `as` #modtime)) ) ( primaryKey #id `as` #pk_user_session ) + + diff --git a/src/Squeal/Orphans.hs b/src/Squeal/Orphans.hs index 6d4f96b..64096ba 100644 --- a/src/Squeal/Orphans.hs +++ b/src/Squeal/Orphans.hs @@ -1,9 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Squeal.Orphans where import Control.Monad.Catch (MonadCatch (..), MonadMask (..), MonadThrow (..)) import Control.Monad.Trans.Class (lift) -import Squeal.PostgreSQL +import Squeal.PostgreSQL (K (..), PQ (..), unK) instance (MonadThrow m, db0 ~ db1) diff --git a/src/Squeal/Query.hs b/src/Squeal/Query.hs index 70595d1..51c5009 100644 --- a/src/Squeal/Query.hs +++ b/src/Squeal/Query.hs @@ -1,8 +1,13 @@ module Squeal.Query where -import ApiTypes -import Squeal.PostgreSQL -import Squeal.Schema +import ApiTypes (Event, PageView, UserSession) +import Squeal.PostgreSQL (ConflictClause (OnConflictDoRaise), + NP ((:*)), Optional (Default, Set), + pattern Returning_, + Statement (Manipulation), pattern Values_, + as, genericRow, insertInto, insertInto_, + manipulation, nilParams, param) +import Squeal.Schema (DB) insertEventPq :: Statement DB Event () insertEventPq = manipulation $ insertInto_ #events $ Values_ $ diff --git a/src/Squeal/Schema.hs b/src/Squeal/Schema.hs index f2f26e5..bf85d04 100644 --- a/src/Squeal/Schema.hs +++ b/src/Squeal/Schema.hs @@ -1,7 +1,10 @@ module Squeal.Schema where -import Squeal.PostgreSQL +import Squeal.PostgreSQL ((:::), (:=>), NullType (NotNull), + Optionality (Def, NoDef), PGType (..), + Public, SchemumType (Table), + TableConstraint (PrimaryKey)) type EventsTable = '[ "id" ::: 'Def :=> 'NotNull 'PGint4 diff --git a/src/Types.hs b/src/Types.hs index d8921dc..13cae68 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -9,23 +9,17 @@ module Types ( , runAppInTransaction ) where -import ApiTypes (Event (..), PageView (..), - UserSession (..)) import Context (Ctx (..)) import Control.Monad.Catch hiding (Handler) import Control.Monad.Extra (ifM) -import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class import Control.Monad.Reader (MonadReader, ask) import Control.Monad.Trans.Class (MonadTrans, lift) -import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Data.Text as T -import qualified Data.UUID.Types as UUID (UUID) import Servant import Squeal.Orphans () import Squeal.PostgreSQL -import Squeal.Schema (DB) import Squeal.Schema @@ -40,7 +34,6 @@ newtype AppT r m a = AppT { unAppT :: ReaderT r m a } , MonadThrow , MonadMask ) -type AppT' = AppT Ctx type App = AppT Ctx (PQ DB DB IO) instance MonadTrans (AppT r) where diff --git a/src/Utils.hs b/src/Utils.hs index 22f6407..24bba2f 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -6,7 +6,6 @@ functions module Utils ( isLeft , isRight - , headMay ) where isLeft :: Either a b -> Bool @@ -15,7 +14,3 @@ isLeft _ = False isRight :: Either a b -> Bool isRight = not . isLeft - -headMay :: [a] -> Maybe a -headMay = Prelude.foldr (\x _ -> Just x) Nothing - diff --git a/test/AnalyticsRouteSpec.hs b/test/AnalyticsRouteSpec.hs index 7347486..47f58ba 100644 --- a/test/AnalyticsRouteSpec.hs +++ b/test/AnalyticsRouteSpec.hs @@ -1,7 +1,7 @@ module AnalyticsRouteSpec (AnalyticsRouteSpec.spec) where import ApiTypes -import Context (Ctx (..)) +import Context (CtxTest (..)) import Helpers (withDB) import Data.Text (unpack) @@ -10,10 +10,10 @@ import Network.HTTP.Client hiding (Proxy) import Servant import Servant.Client -import Utils (isLeft, isRight) import qualified Data.UUID.Types as UUID (nil) import Server (API) import Test.Hspec +import Utils (isLeft, isRight) event :: Event event = Event { @@ -41,7 +41,7 @@ spec = let clientEnv = mkClientEnv manager baseUrl describe "withDB works" $ do it "creates db env" $ \(_, config) -> - Context.port config `shouldBe` 8888 + Context.portT config `shouldBe` 8888 describe "auth" $ do it "auth fails on empty key" $ \(_, _) -> do let eventRoute = fst $ gec myapi @@ -49,22 +49,22 @@ spec = result `shouldSatisfy` isLeft describe "event" $ do it "event endpoint works" $ \(_, config) -> do - let key = Just $ apiKey config + let key = Just $ apiKeyT config let eventRoute = fst $ gec myapi result <- runClientM (eventRoute key event) clientEnv result `shouldBe` Right NoContent it "spacer test (XXX)" $ \(_, config) -> - Context.port config `shouldBe` 8888 + Context.portT config `shouldBe` 8888 describe "pageview" $ do it "pageview endpoint works" $ \(_, config) -> do let pageviewRoute = fst $ gec $ snd $ gec myapi - let key = Just $ apiKey config + let key = Just $ apiKeyT config result <- runClientM (pageviewRoute key pageview) clientEnv result `shouldBe` Right NoContent describe "session" $ do it "session endpoint works" $ \(_, config) -> do let sessionRoute = snd $ gec $ snd $ gec myapi - let key = Just $ apiKey config + let key = Just $ apiKeyT config result <- runClientM (sessionRoute key) clientEnv result `shouldSatisfy` (\x -> isRight x && case x of {Right (UserSession uuid) -> uuid /= UUID.nil; diff --git a/test/Helpers.hs b/test/Helpers.hs index 3ab9e9b..77322e1 100644 --- a/test/Helpers.hs +++ b/test/Helpers.hs @@ -2,32 +2,29 @@ module Helpers (withDB) where -import qualified Data.ByteString.Char8 as BSC -import Data.Maybe (fromMaybe) -import Data.String.Conversions (cs) -import qualified Database.Beam.Postgres as Pg -import Database.Postgres.Temp (DB (..), defaultOptions) -import qualified Database.Postgres.Temp as PG +import qualified Data.ByteString.Char8 as BSC +import Data.String.Conversions (cs) +import Database.Postgres.Temp (DB (..), defaultOptions) +import qualified Database.Postgres.Temp as PG import Protolude -import Context (Ctx (..), readContextFromEnvWithConnStr) -import qualified Control.Concurrent as C -import qualified Data.Text as T -import Database.PostgreSQL.Simple (Query, execute_, - withTransaction) -import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), - MigrationContext (..), - MigrationResult (..), - runMigration) -import Database.PostgreSQL.Simple.Options (Options (..)) -import Database.PostgreSQL.Simple.Types (Query (..)) -import qualified Network.Wai.Handler.Warp as Warp -import Server (app) -import System.Environment (getEnv) -import System.IO (BufferMode (..), - IOMode (WriteMode), - hSetBuffering, openFile, - stderr, stdout) +import Context (Ctx (..), CtxTest (..), + readContextFromEnv, + readContextFromEnvWithConnStr) +import qualified Control.Concurrent as C +import qualified Data.Text as T +import Database.PostgreSQL.Simple (Connection, Query, + connectPostgreSQL, + execute_) +import Database.PostgreSQL.Simple.Options (Options (..)) +import Database.PostgreSQL.Simple.Types (Query (..)) +import qualified Network.Wai.Handler.Warp as Warp +import Server (app) +import Squeal.Migration.V1 +import Squeal.PostgreSQL (renderSQL) +import System.Environment (getEnv) +import System.IO (BufferMode (..), + hSetBuffering) import Test.Hspec --- Setup and teardown helpers --- @@ -38,29 +35,30 @@ data DBLogging = VERBOSE | SILENT deriving Read data TestType = Local | Travis deriving Read -withDB :: SpecWith (IO (), Ctx) -> Spec +withDB :: SpecWith (IO (), CtxTest) -> Spec withDB = beforeAll getDbAndWarpServer . afterAll fst . afterAll (truncateDb . snd) where - getDbAndWarpServer :: IO (IO (), Ctx) + getDbAndWarpServer :: IO (IO (), CtxTest) getDbAndWarpServer = do (_, config) <- getDatabase - _ <- C.forkIO $ runWarpServer config + ctx <- readContextFromEnv + _ <- C.forkIO $ runWarpServer ctx -- Wait 2 seconds for the warp server to boot C.threadDelay 2000000 pure (pure (), config) - getDatabase :: IO (IO (), Ctx) + getDatabase :: IO (IO (), CtxTest) getDatabase = read @TestType <$> (getEnv "TEST_TYPE") >>= \case Local -> createTmpDatabase Travis -> do -- "TRAVIS" let connStr = "postgresql://postgres@localhost/travis_ci_test" config <- readContextFromEnvWithConnStr $ T.pack connStr - migrateDB $ conn config + migrateDB $ connT config pure (pure (), config) - createTmpDatabase :: IO (IO (), Ctx) + createTmpDatabase :: IO (IO (), CtxTest) createTmpDatabase = do verbosity <- read @DBLogging <$> getEnv "DBLOGGING" (db, cleanup) <- startDb verbosity @@ -69,8 +67,8 @@ withDB = beforeAll getDbAndWarpServer return (cleanup, config) -- https://stackoverflow.com/questions/5342440/reset-auto-increment-counter-in-postgres - truncateDb :: Ctx -> IO () - truncateDb config = execute_ (conn config) query_statment >> pure () + truncateDb :: CtxTest -> IO () + truncateDb config = execute_ (connT config) query_statment >> pure () where query_statment = Query $ BSC.pack $ T.unpack truncateStatement :: Query truncateStatement = @@ -92,15 +90,19 @@ withDB = beforeAll getDbAndWarpServer db <- PG.startWithHandles PG.Localhost defaultOptions outHandle errHandle >>= either throwIO pure pguser <- getEnv "PGUSER" - conn <- Pg.connectPostgreSQL $ BSC.pack $ T.unpack $ toConnectionString pguser db + conn <- connectPostgreSQL $ BSC.pack $ T.unpack $ toConnectionString pguser db restore (migrateDB conn >> pure (db, cleanup db)) `onException` cleanup db where devNull = openFile "/dev/null" WriteMode cleanup = void . PG.stop - migrateDB :: Pg.Connection -> IO () - migrateDB con = do + migrateDB :: Connection -> IO () + migrateDB con = + let migrationSql = Query $ renderSQL initMigration + in void $ execute_ con migrationSql + + {- let migrationDir = MigrationDirectory "db/migrations" initResult <- withTransaction con $ runMigration $ MigrationContext MigrationInitialization False con @@ -112,6 +114,7 @@ withDB = beforeAll getDbAndWarpServer migrationResult <- withTransaction con $ runMigration $ MigrationContext migrationDir True con Prelude.print migrationResult + -} runWarpServer :: Ctx -> IO () runWarpServer ctx = do