still working
This commit is contained in:
parent
1386a2d482
commit
ee456f7c11
8 changed files with 40 additions and 36 deletions
3
.gitignore
vendored
3
.gitignore
vendored
|
@ -3,4 +3,5 @@
|
|||
state/
|
||||
dist-newstyle/
|
||||
*.db
|
||||
jwt.key
|
||||
jwt.key
|
||||
*.lock
|
|
@ -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))]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 #-}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 ()
|
||||
|
|
Loading…
Reference in a new issue