diff --git a/IHP/Controller/FileUpload.hs b/IHP/Controller/FileUpload.hs index 444f1a315..a0db92f0a 100644 --- a/IHP/Controller/FileUpload.hs +++ b/IHP/Controller/FileUpload.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, TypeInType, BlockArguments, DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, BlockArguments, DataKinds #-} {-| Module: IHP.Controller.FileUpload diff --git a/IHP/Controller/Param.hs b/IHP/Controller/Param.hs index b6af58660..ae03626f5 100644 --- a/IHP/Controller/Param.hs +++ b/IHP/Controller/Param.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, TypeInType, BlockArguments, DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, BlockArguments, DataKinds #-} {-| Module: IHP.Controller.Param diff --git a/IHP/ErrorController.hs b/IHP/ErrorController.hs index 3ff0f5a80..edf3625b7 100644 --- a/IHP/ErrorController.hs +++ b/IHP/ErrorController.hs @@ -16,7 +16,7 @@ import qualified Network.HTTP.Types.Method as Router import qualified Control.Exception as Exception import qualified Data.Text as Text import IHP.Controller.RequestContext -import Network.HTTP.Types (status500, status404, status400, status403) +import Network.HTTP.Types (status500, status400) import Network.Wai import Network.HTTP.Types.Header @@ -24,14 +24,12 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze import qualified Database.PostgreSQL.Simple as PG import qualified Data.ByteString.Char8 as ByteString -import qualified Data.ByteString.Lazy as LBS import IHP.HSX.QQ (hsx) import qualified IHP.ModelSupport as ModelSupport import IHP.FrameworkConfig import qualified IHP.Environment as Environment import IHP.Controller.Context -import qualified System.Directory as Directory import IHP.ApplicationContext import IHP.Controller.NotFound (handleNotFound) diff --git a/IHP/Fetch.hs b/IHP/Fetch.hs index bb8191fa2..b62a6b287 100644 --- a/IHP/Fetch.hs +++ b/IHP/Fetch.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, TypeFamilies, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, InstanceSigs, AllowAmbiguousTypes, DeriveAnyClass #-} +{-# LANGUAGE BangPatterns, TypeFamilies, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, InstanceSigs, AllowAmbiguousTypes, DeriveAnyClass #-} {-| Module: IHP.Fetch Description: fetch, fetchOne, fetchOneOrNothing and friends diff --git a/IHP/FetchRelated.hs b/IHP/FetchRelated.hs index 6296c0657..159b4765a 100644 --- a/IHP/FetchRelated.hs +++ b/IHP/FetchRelated.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, AllowAmbiguousTypes #-} {-| Module: IHP.FetchRelated Description: Provides fetchRelated, collectionFetchRelated, etc. diff --git a/IHP/HaskellSupport.hs b/IHP/HaskellSupport.hs index 0bf56b06b..a0bc96586 100644 --- a/IHP/HaskellSupport.hs +++ b/IHP/HaskellSupport.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, IncoherentInstances, AllowAmbiguousTypes, FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, IncoherentInstances, AllowAmbiguousTypes, FunctionalDependencies #-} {-| Module: IHP.HaskellSupport diff --git a/IHP/IDE/Data/Controller.hs b/IHP/IDE/Data/Controller.hs index 2c292ae27..8f3c71b7a 100644 --- a/IHP/IDE/Data/Controller.hs +++ b/IHP/IDE/Data/Controller.hs @@ -1,7 +1,6 @@ module IHP.IDE.Data.Controller where import IHP.ControllerPrelude -import IHP.Controller.NotFound import IHP.IDE.ToolServer.Types import IHP.IDE.Data.View.ShowDatabase import IHP.IDE.Data.View.ShowTableRows diff --git a/IHP/Job/Dashboard.hs b/IHP/Job/Dashboard.hs index 9c6694f6e..5f3d3cfdb 100644 --- a/IHP/Job/Dashboard.hs +++ b/IHP/Job/Dashboard.hs @@ -109,7 +109,7 @@ class ( job ~ GetModelByTableName (GetTableName job) -- -- Later functions and typeclasses introduce constraints on the types in this list, -- so you'll get a compile error if you try and include a type that is not a job. -class JobsDashboard (jobs :: [*]) where +class JobsDashboard (jobs :: [Type]) where -- | Creates the entire dashboard by recursing on the type list and calling 'makeDashboardSection' on each type. makeDashboard :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO SomeView diff --git a/IHP/Job/Dashboard/Types.hs b/IHP/Job/Dashboard/Types.hs index 0d3144b83..f748fd954 100644 --- a/IHP/Job/Dashboard/Types.hs +++ b/IHP/Job/Dashboard/Types.hs @@ -72,7 +72,7 @@ newtype IncludeWrapper (id :: Symbol) job = IncludeWrapper (Include id job) -- | Defines controller actions for acting on a dashboard made of some list of types. -- Later functions and typeclasses introduce constraints on the types in this list, -- so you'll get a compile error if you try and include a type that is not a job. -data JobsDashboardController authType (jobs :: [*]) +data JobsDashboardController authType (jobs :: [Type]) = ListJobsAction | ListJobAction { jobTableName :: Text, page :: Int } -- These actions are used for 'pathTo'. Need to pass the parameters explicity to know how to build the path diff --git a/IHP/ModelSupport.hs b/IHP/ModelSupport.hs index e083acae6..485fe43c6 100644 --- a/IHP/ModelSupport.hs +++ b/IHP/ModelSupport.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, UndecidableInstances, FlexibleInstances, IncoherentInstances, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, UndecidableInstances, FlexibleInstances, IncoherentInstances, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, GeneralizedNewtypeDeriving #-} module IHP.ModelSupport ( module IHP.ModelSupport @@ -85,10 +85,8 @@ notConnectedModelContext logger = ModelContext createModelContext :: NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext createModelContext idleTime maxConnections databaseUrl logger = do - numStripes <- GHC.Conc.getNumCapabilities - let create = PG.connectPostgreSQL databaseUrl - let destroy = PG.close - connectionPool <- Pool.createPool create destroy numStripes idleTime maxConnections + let poolConfig = Pool.defaultPoolConfig (PG.connectPostgreSQL databaseUrl) PG.close (realToFrac idleTime) maxConnections + connectionPool <- Pool.newPool poolConfig let trackTableReadCallback = Nothing let transactionConnection = Nothing @@ -364,6 +362,8 @@ measureTimeIfLogging queryAction theQuery theParameters = do -- -- *AutoRefresh:* When using 'sqlQuery' with AutoRefresh, you need to use 'trackTableRead' to let AutoRefresh know that you have accessed a certain table. Otherwise AutoRefresh will not watch table of your custom sql query. -- +-- Use 'sqlQuerySingleRow' if you expect only a single row to be returned. +-- sqlQuery :: (?modelContext :: ModelContext, PG.ToRow q, PG.FromRow r) => Query -> q -> IO [r] sqlQuery theQuery theParameters = do measureTimeIfLogging @@ -374,6 +374,28 @@ sqlQuery theQuery theParameters = do theParameters {-# INLINABLE sqlQuery #-} + +-- | Runs a raw sql query, that is expected to return a single result row +-- +-- Like 'sqlQuery', but useful when you expect only a single row as the result +-- +-- __Example:__ +-- +-- > user <- sqlQuerySingleRow "SELECT id, firstname, lastname FROM users WHERE id = ?" (Only user.id) +-- +-- Take a look at "IHP.QueryBuilder" for a typesafe approach on building simple queries. +-- +-- *AutoRefresh:* When using 'sqlQuerySingleRow' with AutoRefresh, you need to use 'trackTableRead' to let AutoRefresh know that you have accessed a certain table. Otherwise AutoRefresh will not watch table of your custom sql query. +-- +sqlQuerySingleRow :: (?modelContext :: ModelContext, PG.ToRow query, PG.FromRow record) => Query -> query -> IO record +sqlQuerySingleRow theQuery theParameters = do + result <- sqlQuery theQuery theParameters + case result of + [] -> error ("sqlQuerySingleRow: Expected a single row to be returned. Query: " <> show theQuery) + [record] -> pure record + otherwise -> error ("sqlQuerySingleRow: Expected a single row to be returned. But got " <> show (length otherwise) <> " rows") +{-# INLINABLE sqlQuerySingleRow #-} + -- | Runs a sql statement (like a CREATE statement) -- -- __Example:__ diff --git a/IHP/Prelude.hs b/IHP/Prelude.hs index fdfda0be0..28693f1fe 100644 --- a/IHP/Prelude.hs +++ b/IHP/Prelude.hs @@ -41,6 +41,7 @@ module IHP.Prelude , module Control.Concurrent.Async , module NeatInterpolation , module GHC.Stack +, module Data.Kind ) where @@ -56,7 +57,6 @@ import qualified Data.Text as Text import Data.Proxy (Proxy (Proxy)) import Control.Monad (when, unless, mapM, mapM_, forM, forM_, sequence, sequence_, join, forever) import Data.List hiding (head, last, unwords, unlines, words, lines, isPrefixOf, isSuffixOf, isInfixOf, intercalate, intersperse, (++), splitAt, null, tail, init) -import qualified Data.List as List import Data.String.Conversions (ConvertibleStrings (convertString), cs) import Data.Time.Clock import Data.Time.Calendar @@ -77,6 +77,7 @@ import Control.Monad.Fail (fail) import Control.Concurrent.Async import NeatInterpolation (trimming) import GHC.Stack (HasCallStack, CallStack) +import Data.Kind (Type) -- Alias for haskell newcomers :) a ++ b = a <> b @@ -92,28 +93,28 @@ error message = Prelude.error (Text.unpack message) head :: [a] -> Maybe a head [] = Nothing -head list = Just (List.head list) +head (firstItem:rest) = Just firstItem headMay :: [a] -> Maybe a headMay = head last :: [a] -> Maybe a last [] = Nothing -last list = Just (List.last list) +last [item] = Just item +last (_:rest) = last rest lastMay :: [a] -> Maybe a lastMay = last tail :: [a] -> Maybe [a] +tail (_:rest) = Just rest tail [] = Nothing -tail list = Just (List.tail list) tailMay :: [a] -> Maybe [a] tailMay = tail init :: [a] -> Maybe [a] -init [] = Nothing -init list = Just (List.init list) +init list = fst <$> (unsnoc list) initMay :: [a] -> Maybe [a] initMay = init diff --git a/IHP/QueryBuilder.hs b/IHP/QueryBuilder.hs index 4432b4ea0..f74e366e4 100644 --- a/IHP/QueryBuilder.hs +++ b/IHP/QueryBuilder.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, TypeFamilies, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, InstanceSigs, AllowAmbiguousTypes, DeriveAnyClass #-} +{-# LANGUAGE BangPatterns, TypeFamilies, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, InstanceSigs, AllowAmbiguousTypes, DeriveAnyClass #-} {-| Module: IHP.QueryBuilder Description: Tool to build simple sql queries @@ -539,7 +539,7 @@ filterWhereNotJoinedTable (name, value) queryBuilderProvider = injectQueryBuilde -- -- For negation use 'filterWhereNotIn' -- -filterWhereIn :: forall name table model value queryBuilderProvider (joinRegister :: *). (KnownSymbol table, KnownSymbol name, ToField value, HasField name model value, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister, EqOrIsOperator value, Table model) => (Proxy name, [value]) -> queryBuilderProvider table -> queryBuilderProvider table +filterWhereIn :: forall name table model value queryBuilderProvider (joinRegister :: Type). (KnownSymbol table, KnownSymbol name, ToField value, HasField name model value, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister, EqOrIsOperator value, Table model) => (Proxy name, [value]) -> queryBuilderProvider table -> queryBuilderProvider table filterWhereIn (name, value) queryBuilderProvider = case head nullValues of Nothing -> injectQueryBuilder whereInQuery -- All values non null @@ -831,7 +831,7 @@ filterWhereCaseInsensitive (name, value) queryBuilderProvider = injectQueryBuild {-# INLINE filterWhereCaseInsensitive #-} -filterWhereIdIn :: forall table model queryBuilderProvider (joinRegister :: *). (KnownSymbol table, Table model, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister) => [Id model] -> queryBuilderProvider table -> queryBuilderProvider table +filterWhereIdIn :: forall table model queryBuilderProvider (joinRegister :: Type). (KnownSymbol table, Table model, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister) => [Id model] -> queryBuilderProvider table -> queryBuilderProvider table filterWhereIdIn values queryBuilderProvider = -- We don't need to treat null values differently here, because primary keys imply not-null let diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs index 10fd3dff3..9f14b198c 100644 --- a/IHP/SchemaCompiler.hs +++ b/IHP/SchemaCompiler.hs @@ -545,7 +545,7 @@ compileCreate table@(CreateTable { name, columns }) = <> indent ( "create :: (?modelContext :: ModelContext) => " <> modelName <> " -> IO " <> modelName <> "\n" <> "create model = do\n" - <> indent ("List.head <$> sqlQuery \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES (" <> values <> ") RETURNING " <> columnNames <> "\" (" <> compileToRowValues bindings <> ")\n") + <> indent ("sqlQuerySingleRow \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES (" <> values <> ") RETURNING " <> columnNames <> "\" (" <> compileToRowValues bindings <> ")\n") <> "createMany [] = pure []\n" <> "createMany models = do\n" <> indent ("sqlQuery (Query $ \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES \" <> (ByteString.intercalate \", \" (List.map (\\_ -> \"(" <> values <> ")\") models)) <> \" RETURNING " <> columnNames <> "\") " <> createManyFieldValues <> "\n" @@ -595,7 +595,7 @@ compileUpdate table@(CreateTable { name, columns }) = "instance CanUpdate " <> modelName <> " where\n" <> indent ("updateRecord model = do\n" <> indent ( - "List.head <$> sqlQuery \"UPDATE " <> name <> " SET " <> updates <> " WHERE " <> primaryKeyPattern <> " = "<> primaryKeyParameters <> " RETURNING " <> columnNames <> "\" (" <> bindings <> ")\n" + "sqlQuerySingleRow \"UPDATE " <> name <> " SET " <> updates <> " WHERE " <> primaryKeyPattern <> " = "<> primaryKeyParameters <> " RETURNING " <> columnNames <> "\" (" <> bindings <> ")\n" ) ) diff --git a/IHP/Test/Database.hs b/IHP/Test/Database.hs index 607441481..01f91f2d9 100644 --- a/IHP/Test/Database.hs +++ b/IHP/Test/Database.hs @@ -6,12 +6,10 @@ import qualified Database.PostgreSQL.Simple.Types as PG import qualified Data.UUID.V4 as UUID import qualified Data.UUID as UUID import qualified Data.Text as Text -import qualified Data.ByteString as ByteString import qualified IHP.LibDir as LibDir import qualified Control.Exception as Exception import qualified System.Process as Process -import qualified System.Directory as Directory data TestDatabase = TestDatabase { name :: Text diff --git a/Test/SchemaCompilerSpec.hs b/Test/SchemaCompilerSpec.hs index 8329e26e4..3df0555d3 100644 --- a/Test/SchemaCompilerSpec.hs +++ b/Test/SchemaCompilerSpec.hs @@ -133,7 +133,7 @@ tests = do instance CanCreate User where create :: (?modelContext :: ModelContext) => User -> IO User create model = do - List.head <$> sqlQuery "INSERT INTO users (id) VALUES (?) RETURNING id" (Only (model.id)) + sqlQuerySingleRow "INSERT INTO users (id) VALUES (?) RETURNING id" (Only (model.id)) createMany [] = pure [] createMany models = do sqlQuery (Query $ "INSERT INTO users (id) VALUES " <> (ByteString.intercalate ", " (List.map (\_ -> "(?)") models)) <> " RETURNING id") (List.concat $ List.map (\model -> [toField (model.id)]) models) @@ -142,7 +142,7 @@ tests = do getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming| instance CanUpdate User where updateRecord model = do - List.head <$> sqlQuery "UPDATE users SET id = ? WHERE id = ? RETURNING id" ((fieldWithUpdate #id model, model.id)) + sqlQuerySingleRow "UPDATE users SET id = ? WHERE id = ? RETURNING id" ((fieldWithUpdate #id model, model.id)) |] it "should compile CanUpdate instance with an array type with an explicit cast" do @@ -158,7 +158,7 @@ tests = do getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming| instance CanUpdate User where updateRecord model = do - List.head <$> sqlQuery "UPDATE users SET id = ?, ids = ? :: UUID[] WHERE id = ? RETURNING id, ids" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, model.id)) + sqlQuerySingleRow "UPDATE users SET id = ?, ids = ? :: UUID[] WHERE id = ? RETURNING id, ids" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, model.id)) |] it "should deal with double default values" do let statement = StatementCreateTable CreateTable @@ -211,14 +211,14 @@ tests = do instance CanCreate User where create :: (?modelContext :: ModelContext) => User -> IO User create model = do - List.head <$> sqlQuery "INSERT INTO users (id, ids, electricity_unit_price) VALUES (?, ? :: UUID[], ?) RETURNING id, ids, electricity_unit_price" ((model.id, model.ids, fieldWithDefault #electricityUnitPrice model)) + sqlQuerySingleRow "INSERT INTO users (id, ids, electricity_unit_price) VALUES (?, ? :: UUID[], ?) RETURNING id, ids, electricity_unit_price" ((model.id, model.ids, fieldWithDefault #electricityUnitPrice model)) createMany [] = pure [] createMany models = do sqlQuery (Query $ "INSERT INTO users (id, ids, electricity_unit_price) VALUES " <> (ByteString.intercalate ", " (List.map (\_ -> "(?, ? :: UUID[], ?)") models)) <> " RETURNING id, ids, electricity_unit_price") (List.concat $ List.map (\model -> [toField (model.id), toField (model.ids), toField (fieldWithDefault #electricityUnitPrice model)]) models) instance CanUpdate User where updateRecord model = do - List.head <$> sqlQuery "UPDATE users SET id = ?, ids = ? :: UUID[], electricity_unit_price = ? WHERE id = ? RETURNING id, ids, electricity_unit_price" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, fieldWithUpdate #electricityUnitPrice model, model.id)) + sqlQuerySingleRow "UPDATE users SET id = ?, ids = ? :: UUID[], electricity_unit_price = ? WHERE id = ? RETURNING id, ids, electricity_unit_price" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, fieldWithUpdate #electricityUnitPrice model, model.id)) instance Record User where {-# INLINE newRecord #-} @@ -281,14 +281,14 @@ tests = do instance CanCreate User where create :: (?modelContext :: ModelContext) => User -> IO User create model = do - List.head <$> sqlQuery "INSERT INTO users (id, ids, electricity_unit_price) VALUES (?, ? :: UUID[], ?) RETURNING id, ids, electricity_unit_price" ((model.id, model.ids, fieldWithDefault #electricityUnitPrice model)) + sqlQuerySingleRow "INSERT INTO users (id, ids, electricity_unit_price) VALUES (?, ? :: UUID[], ?) RETURNING id, ids, electricity_unit_price" ((model.id, model.ids, fieldWithDefault #electricityUnitPrice model)) createMany [] = pure [] createMany models = do sqlQuery (Query $ "INSERT INTO users (id, ids, electricity_unit_price) VALUES " <> (ByteString.intercalate ", " (List.map (\_ -> "(?, ? :: UUID[], ?)") models)) <> " RETURNING id, ids, electricity_unit_price") (List.concat $ List.map (\model -> [toField (model.id), toField (model.ids), toField (fieldWithDefault #electricityUnitPrice model)]) models) instance CanUpdate User where updateRecord model = do - List.head <$> sqlQuery "UPDATE users SET id = ?, ids = ? :: UUID[], electricity_unit_price = ? WHERE id = ? RETURNING id, ids, electricity_unit_price" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, fieldWithUpdate #electricityUnitPrice model, model.id)) + sqlQuerySingleRow "UPDATE users SET id = ?, ids = ? :: UUID[], electricity_unit_price = ? WHERE id = ? RETURNING id, ids, electricity_unit_price" ((fieldWithUpdate #id model, fieldWithUpdate #ids model, fieldWithUpdate #electricityUnitPrice model, model.id)) instance Record User where {-# INLINE newRecord #-} @@ -350,14 +350,14 @@ tests = do instance CanCreate User where create :: (?modelContext :: ModelContext) => User -> IO User create model = do - List.head <$> sqlQuery "INSERT INTO users (id) VALUES (?) RETURNING id" (Only (model.id)) + sqlQuerySingleRow "INSERT INTO users (id) VALUES (?) RETURNING id" (Only (model.id)) createMany [] = pure [] createMany models = do sqlQuery (Query $ "INSERT INTO users (id) VALUES " <> (ByteString.intercalate ", " (List.map (\_ -> "(?)") models)) <> " RETURNING id") (List.concat $ List.map (\model -> [toField (model.id)]) models) instance CanUpdate User where updateRecord model = do - List.head <$> sqlQuery "UPDATE users SET id = ? WHERE id = ? RETURNING id" ((fieldWithUpdate #id model, model.id)) + sqlQuerySingleRow "UPDATE users SET id = ? WHERE id = ? RETURNING id" ((fieldWithUpdate #id model, model.id)) instance Record User where {-# INLINE newRecord #-} @@ -427,14 +427,14 @@ tests = do instance CanCreate LandingPage where create :: (?modelContext :: ModelContext) => LandingPage -> IO LandingPage create model = do - List.head <$> sqlQuery "INSERT INTO landing_pages (id) VALUES (?) RETURNING id" (Only (fieldWithDefault #id model)) + sqlQuerySingleRow "INSERT INTO landing_pages (id) VALUES (?) RETURNING id" (Only (fieldWithDefault #id model)) createMany [] = pure [] createMany models = do sqlQuery (Query $ "INSERT INTO landing_pages (id) VALUES " <> (ByteString.intercalate ", " (List.map (\_ -> "(?)") models)) <> " RETURNING id") (List.concat $ List.map (\model -> [toField (fieldWithDefault #id model)]) models) instance CanUpdate LandingPage where updateRecord model = do - List.head <$> sqlQuery "UPDATE landing_pages SET id = ? WHERE id = ? RETURNING id" ((fieldWithUpdate #id model, model.id)) + sqlQuerySingleRow "UPDATE landing_pages SET id = ? WHERE id = ? RETURNING id" ((fieldWithUpdate #id model, model.id)) instance Record LandingPage where {-# INLINE newRecord #-} @@ -469,7 +469,7 @@ tests = do instance CanCreate Thing where create :: (?modelContext :: ModelContext) => Thing -> IO Thing create model = do - List.head <$> sqlQuery "INSERT INTO things (thing_arbitrary_ident) VALUES (?) RETURNING thing_arbitrary_ident" (Only (fieldWithDefault #thingArbitraryIdent model)) + sqlQuerySingleRow "INSERT INTO things (thing_arbitrary_ident) VALUES (?) RETURNING thing_arbitrary_ident" (Only (fieldWithDefault #thingArbitraryIdent model)) createMany [] = pure [] createMany models = do sqlQuery (Query $ "INSERT INTO things (thing_arbitrary_ident) VALUES " <> (ByteString.intercalate ", " (List.map (\_ -> "(?)") models)) <> " RETURNING thing_arbitrary_ident") (List.concat $ List.map (\model -> [toField (fieldWithDefault #thingArbitraryIdent model)]) models) @@ -478,7 +478,7 @@ tests = do getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming| instance CanUpdate Thing where updateRecord model = do - List.head <$> sqlQuery "UPDATE things SET thing_arbitrary_ident = ? WHERE thing_arbitrary_ident = ? RETURNING thing_arbitrary_ident" ((fieldWithUpdate #thingArbitraryIdent model, model.thingArbitraryIdent)) + sqlQuerySingleRow "UPDATE things SET thing_arbitrary_ident = ? WHERE thing_arbitrary_ident = ? RETURNING thing_arbitrary_ident" ((fieldWithUpdate #thingArbitraryIdent model, model.thingArbitraryIdent)) |] it "should compile FromRow instance" $ \statement -> do getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming| @@ -533,7 +533,7 @@ tests = do instance CanCreate BitPartRef where create :: (?modelContext :: ModelContext) => BitPartRef -> IO BitPartRef create model = do - List.head <$> sqlQuery "INSERT INTO bit_part_refs (bit_ref, part_ref) VALUES (?, ?) RETURNING bit_ref, part_ref" ((model.bitRef, model.partRef)) + sqlQuerySingleRow "INSERT INTO bit_part_refs (bit_ref, part_ref) VALUES (?, ?) RETURNING bit_ref, part_ref" ((model.bitRef, model.partRef)) createMany [] = pure [] createMany models = do sqlQuery (Query $ "INSERT INTO bit_part_refs (bit_ref, part_ref) VALUES " <> (ByteString.intercalate ", " (List.map (\_ -> "(?, ?)") models)) <> " RETURNING bit_ref, part_ref") (List.concat $ List.map (\model -> [toField (model.bitRef), toField (model.partRef)]) models) @@ -542,7 +542,7 @@ tests = do getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming| instance CanUpdate BitPartRef where updateRecord model = do - List.head <$> sqlQuery "UPDATE bit_part_refs SET bit_ref = ?, part_ref = ? WHERE (bit_ref, part_ref) = (?, ?) RETURNING bit_ref, part_ref" ((fieldWithUpdate #bitRef model, fieldWithUpdate #partRef model, model.bitRef, model.partRef)) + sqlQuerySingleRow "UPDATE bit_part_refs SET bit_ref = ?, part_ref = ? WHERE (bit_ref, part_ref) = (?, ?) RETURNING bit_ref, part_ref" ((fieldWithUpdate #bitRef model, fieldWithUpdate #partRef model, model.bitRef, model.partRef)) |] it "should compile FromRow instance" $ \statement -> do getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming| diff --git a/devenv-module.nix b/devenv-module.nix index e4e271458..8b32c3e6d 100644 --- a/devenv-module.nix +++ b/devenv-module.nix @@ -120,5 +120,9 @@ that is defined in flake-module.nix languages.haskell.stack = null; # Stack is not used in IHP languages.haskell.languageServer = ghcCompiler.haskell-language-server; }; + + packages = { + default = ghcCompiler.ihp; + }; }; } diff --git a/lib/IHP/applicationGhciConfig b/lib/IHP/applicationGhciConfig index e7004f054..6ad6ce45e 100755 --- a/lib/IHP/applicationGhciConfig +++ b/lib/IHP/applicationGhciConfig @@ -51,4 +51,5 @@ :set -Werror=missing-fields :set -fwarn-incomplete-patterns :set -package ghc +:set -fno-warn-ambiguous-fields :l Main.hs \ No newline at end of file