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 diff --git a/db/Migrations.hs b/db/Migrations.hs index 53e6112..f065aaa 100644 --- a/db/Migrations.hs +++ b/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 diff --git a/package.yaml b/package.yaml index 76510eb..3225b4c 100644 --- a/package.yaml +++ b/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 +- 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 diff --git a/src/ApiTypes.hs b/src/ApiTypes.hs index 2800d46..f72e44a 100644 --- a/src/ApiTypes.hs +++ b/src/ApiTypes.hs @@ -2,28 +2,18 @@ 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 @@ -31,36 +21,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 - -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 05bdce0..d44092c 100644 --- a/src/Context.hs +++ b/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") diff --git a/src/Db.hs b/src/Db.hs deleted file mode 100644 index ff59cf6..0000000 --- a/src/Db.hs +++ /dev/null @@ -1,94 +0,0 @@ -module Db - ( - PageViewDBT(..) - , PageViewId - , EventsDBT(..) - , EventsId - , UserSessionDBT(..) - , UserSessionId - , AnalyticsDb(..) - , analyticsDb - ) 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 9d3b92d..0623135 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -7,9 +7,8 @@ module Server ( , runMain ) where -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Reader (runReaderT) -import Data.Maybe (fromMaybe) +import Control.Monad ((<=<)) +import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Text as T import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, @@ -39,13 +38,15 @@ import ApiTypes (Event (..), UserSession (..)) import Context (Ctx (..), readContextFromEnv) -import Db -import Types (AppM, getContext, - insertEvent, - insertPageView, - insertUserSession, +import qualified Squeal.PostgreSQL as Sq +import Squeal.Query (insertEventPq, + insertPageViewPq, + insertSessionPq) +import Squeal.Schema (DB) +import Types (App, MonadAuth, + runAppInTransaction, withAuth) -import qualified Utils (headMay) + data Routes route = Routes { event :: route :- "event" @@ -63,54 +64,59 @@ 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 :: + ( 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 :: Maybe T.Text -> PageView -> AppM Ctx NoContent + page :: + ( 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 :: Maybe T.Text -> AppM Ctx UserSession + session :: + ( MonadIO m + , MonadAuth m + , Sq.MonadPQ DB m) + => Maybe T.Text -> m UserSession session auth = withAuth auth $ do - Ctx{ conn } <- getContext - status <- insertUserSession conn - return $ UserSession $ (usersessionId . getSingleResult) status - getSingleResult lst = - -- TODO code smell: headMay then toss an error? - fromMaybe (error $ "storeRun: single item not returned: " ++ show lst ) - $ Utils.headMay lst + Sq.execute insertSessionPq >>= Sq.getRow 0 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 @@ -124,4 +130,3 @@ runMain = do setBeforeMainLoop (hPutStrLn stderr ("listening on port " ++ show (port ctx))) $ defaultSettings runSettings settings (app ctx) - diff --git a/src/Squeal/Migration/V1.hs b/src/Squeal/Migration/V1.hs new file mode 100644 index 0000000..94f8f5f --- /dev/null +++ b/src/Squeal/Migration/V1.hs @@ -0,0 +1,32 @@ +module Squeal.Migration.V1 where + +import Squeal.PostgreSQL +import Squeal.Schema + + +initMigration :: Definition (Public '[]) DB +initMigration = dropTableIfExists #events >>> + 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 ) >>> + dropTableIfExists #page_view >>> + 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 ) >>> + 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)) + ) + ( primaryKey #id `as` #pk_user_session ) + + diff --git a/src/Squeal/Orphans.hs b/src/Squeal/Orphans.hs new file mode 100644 index 0000000..64096ba --- /dev/null +++ b/src/Squeal/Orphans.hs @@ -0,0 +1,32 @@ +{-# 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 (K (..), PQ (..), unK) + + +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..51c5009 --- /dev/null +++ b/src/Squeal/Query.hs @@ -0,0 +1,32 @@ +module Squeal.Query where + +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_ $ + 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..bf85d04 --- /dev/null +++ b/src/Squeal/Schema.hs @@ -0,0 +1,38 @@ + +module Squeal.Schema where + +import Squeal.PostgreSQL ((:::), (:=>), NullType (NotNull), + Optionality (Def, NoDef), PGType (..), + Public, SchemumType (Table), + TableConstraint (PrimaryKey)) + +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 diff --git a/src/Types.hs b/src/Types.hs index f5adddd..13cae68 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,69 +1,74 @@ +{-# LANGUAGE UndecidableInstances #-} module Types ( - AppM + App , MonadAuth , withAuth - , MonadDb - , insertUserSession - , fetchUserSession - , insertPageView - , insertEvent , HasContext , getContext + , getPool + , runAppInTransaction ) where -import ApiTypes (Event (..), - PageView (..), - UserSession (..), - convertToDb) -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 qualified Data.Text as T -import qualified Data.UUID.Types as UUID (nil) -import Database.Beam as B -import Database.Beam.Backend.SQL.BeamExtensions (runInsertReturningList) -import qualified Database.Beam.Postgres as Pg -import Db +import Context (Ctx (..)) +import Control.Monad.Catch hiding (Handler) +import Control.Monad.Extra (ifM) +import Control.Monad.IO.Class +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import qualified Data.Text as T import Servant -import Servant.Server (err403) +import Squeal.Orphans () +import Squeal.PostgreSQL +import Squeal.Schema -type AppM ctx = ReaderT ctx Handler -class (Monad m) => MonadAuth m where +newtype AppT r m a = AppT { unAppT :: ReaderT r m a } + deriving newtype + ( Functor + , Applicative + , Monad + , MonadReader r + , MonadIO + , MonadCatch + , MonadThrow + , MonadMask + ) +type App = AppT Ctx (PQ DB DB IO) + +instance MonadTrans (AppT r) where + lift = AppT . lift + +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 -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 $ err403) where - isCorrectAuth :: Maybe T.Text -> AppM Ctx Bool + isCorrectAuth :: HasContext m => Maybe T.Text -> m Bool isCorrectAuth auth' = do - Ctx{..} <- getContext + Ctx{..} <- ask pure $ auth' == Just apiKey -class Monad m => HasContext m where +class HasContext m => HasDbConn m where + getPool :: m (Pool (K Connection DB)) +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 => MonadDb m where - insertUserSession :: Pg.Connection -> m [UserSessionDBT Identity] - fetchUserSession :: Pg.Connection -> m UserSession - insertPageView :: Pg.Connection -> PageView -> m () - insertEvent :: Pg.Connection -> Event -> m () - -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] - diff --git a/src/Utils.hs b/src/Utils.hs index f231643..24bba2f 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,22 +1,16 @@ +{-| 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 isRight :: Either a b -> Bool isRight = not . isLeft - --- headMay, borrowed from Protolude -headMay :: [a] -> Maybe a -headMay = Prelude.foldr (\x _ -> Just x) Nothing - 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 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