diff --git a/.gitignore b/.gitignore index 4bfe6f9..efdd110 100644 --- a/.gitignore +++ b/.gitignore @@ -3,4 +3,5 @@ state/ dist-newstyle/ *.db -jwt.key \ No newline at end of file +jwt.key +*.lock \ No newline at end of file diff --git a/src-benchmark/Main.hs b/src-benchmark/Main.hs index 7741a36..12eef8e 100644 --- a/src-benchmark/Main.hs +++ b/src-benchmark/Main.hs @@ -3,7 +3,8 @@ import Protolude import Criterion import Criterion.Main -import Lib (inc) +inc :: Int -> Int +inc = (+1) main :: IO () main = defaultMain [bench "inc 41" (whnf inc (41 :: Int))] diff --git a/src/Aggreact.hs b/src/Aggreact.hs index 4bac5da..0d6125e 100644 --- a/src/Aggreact.hs +++ b/src/Aggreact.hs @@ -109,7 +109,7 @@ mainServe conf = do initialize :: Conf -> IO (Settings,Application) initialize Conf{..} = do uh <- newUserHandler userDBConf defaultAdminUser - ch <- newCommentHandler aggreactDB (dbstore uh) commentDBConf + ch <- newCommentHandler aggreactDB commentDBConf sh <- newSlugHandler slugDBConf ah <- newAuthorizationHandler authorizationStrategy myKey <- readKey jwtKeyFilePath diff --git a/src/Aggreact/Auth.hs b/src/Aggreact/Auth.hs index cf3c384..4e41f33 100644 --- a/src/Aggreact/Auth.hs +++ b/src/Aggreact/Auth.hs @@ -5,6 +5,7 @@ -- Common Pragmas (already stated in cabal file but repeated here for some tools) {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE NamedWildCards #-} diff --git a/src/Aggreact/Comments/StoreService.hs b/src/Aggreact/Comments/StoreService.hs index df7c939..41a952b 100644 --- a/src/Aggreact/Comments/StoreService.hs +++ b/src/Aggreact/Comments/StoreService.hs @@ -44,21 +44,17 @@ import Protolude -------------------------------------------------------------------------------- import Aggreact.Comments.Types import Aggreact.DB -import qualified Aggreact.Users as User +import qualified Aggreact.Users as User -------------------------------------------------------------------------------- -import Data.Time.Format () -import Database.SQLite.Simple (Connection,query_) - - -import Database.Beam (references_) -import qualified Database.Beam as Beam -import qualified Database.Beam.Sqlite as BeamSqlite -import Database.Store (DefaultMetas (..), Id (..), - Store (..)) -import Database.Store.Backend.SQLite as SQL -import qualified Database.Store.CRUD as CRUD -import qualified Database.Store.Search as Search +import qualified Database.Beam as Beam +import qualified Database.Beam.Sqlite as BeamSqlite +import Database.SQLite.Simple (Connection, query_) +import Database.Store (DefaultMetas (..), Id (..), + Store (..)) +import Database.Store.Backend.SQLite as SQL +import qualified Database.Store.CRUD as CRUD +import qualified Database.Store.Search as Search type CommentSQLiteStore = SQLiteStore IO DefaultMetas NewComment type DBStore = StartedStore CommentSQLiteStore @@ -117,13 +113,13 @@ commentsView' conn db (Slug sl) = do res <- BeamSqlite.runBeamSqliteDebug putStrLn conn $ Beam.runSelectReturningList $ Beam.select $ do comment <- Beam.all_ (_aggreactComments db) - Beam.guard_ ((_slug comment) Beam.==. Beam.val_ sl) + Beam.guard_ (_slug comment Beam.==. Beam.val_ sl) muser <- Beam.leftJoin_ (Beam.all_ (_aggreactUsers db)) - (\u -> (Beam.maybe_ + (\u -> Beam.maybe_ (Beam.val_ False) - (Beam.==. (User._id u)) - (_userid comment))) + (Beam.==. User._id u) + (_userid comment)) pure (comment,muser) traverse (\(c,mu) -> pure $ CommentView @@ -147,8 +143,11 @@ data CommentHandler = CommentHandler -- | Init a new comment handler -- newCommentHandler :: AggreactDB e -> User.DBStore -> CommentDBConf -> IO CommentHandler -newCommentHandler :: Beam.Database BeamSqlite.Sqlite db => AggreactDB (Beam.DatabaseEntity BeamSqlite.Sqlite db) -> p -> CommentDBConf -> IO CommentHandler -newCommentHandler db userStore conf = do +newCommentHandler :: Beam.Database BeamSqlite.Sqlite db + => AggreactDB (Beam.DatabaseEntity BeamSqlite.Sqlite db) + -> CommentDBConf + -> IO CommentHandler +newCommentHandler db conf = do dbstore <- initDBComments conf pure CommentHandler { createComment = createComment' dbstore , readComment = readComment' dbstore diff --git a/src/Aggreact/Comments/Types.hs b/src/Aggreact/Comments/Types.hs index 51e294e..321f628 100644 --- a/src/Aggreact/Comments/Types.hs +++ b/src/Aggreact/Comments/Types.hs @@ -52,7 +52,7 @@ where import Protolude -import Aggreact.Users (User, UserId (..), BUserT) +import Aggreact.Users (User, UserId (..)) import qualified Control.Exception as Ex import Data.Aeson (FromJSON (..), ToJSON (..), @@ -140,15 +140,16 @@ bCommentToCommentNoUser :: BComment -> Comment bCommentToCommentNoUser bc = Entity (Id (toS (_id bc))) - (NewComment - { parent = ParentId (fmap toS (_parent bc)) - , slug = Slug (_slug bc) - , content = Content (_content bc) - , userid = MUserId Nothing - }) - (DefaultMetas - { updated = _updated bc - , created = _created bc }) + NewComment + { parent = ParentId (fmap toS (_parent bc)) + , slug = Slug (_slug bc) + , content = Content (_content bc) + , userid = MUserId Nothing + } + DefaultMetas + { updated = _updated bc + , created = _created bc + } data BCommentT f = BCommentT diff --git a/src/Aggreact/DB.hs b/src/Aggreact/DB.hs index d11ae59..d4a5a19 100644 --- a/src/Aggreact/DB.hs +++ b/src/Aggreact/DB.hs @@ -1,14 +1,15 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveGeneric #-} @@ -47,7 +48,7 @@ import Protolude import Aggreact.Comments.Types import Aggreact.Users.Types -import qualified Database.Beam as Beam +import qualified Database.Beam as Beam data AggreactDB f = AggreactDB { _aggreactUsers :: f (Beam.TableEntity BUserT) diff --git a/src/Service/Service.hs b/src/Service/Service.hs index f921c10..71d92e6 100644 --- a/src/Service/Service.hs +++ b/src/Service/Service.hs @@ -34,8 +34,8 @@ import Protolude hiding (Handle) import Control.Exception (bracket) class Service s a where - type Config s a -- | the initial config a service should have - type Handle s a -- | a type that should contains methods provided by the service + type Config s a -- the initial config a service should have + type Handle s a -- a type that should contains methods provided by the service init :: Proxy (Service s a) -> Config s a -> IO (Handle s a) stop :: Proxy (Service s a) -> Handle s a -> IO () stop _ _ = pure ()