still working
This commit is contained in:
parent
1386a2d482
commit
ee456f7c11
8 changed files with 40 additions and 36 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
@ -4,3 +4,4 @@ state/
|
||||||
dist-newstyle/
|
dist-newstyle/
|
||||||
*.db
|
*.db
|
||||||
jwt.key
|
jwt.key
|
||||||
|
*.lock
|
|
@ -3,7 +3,8 @@ import Protolude
|
||||||
import Criterion
|
import Criterion
|
||||||
import Criterion.Main
|
import Criterion.Main
|
||||||
|
|
||||||
import Lib (inc)
|
inc :: Int -> Int
|
||||||
|
inc = (+1)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = defaultMain [bench "inc 41" (whnf inc (41 :: Int))]
|
main = defaultMain [bench "inc 41" (whnf inc (41 :: Int))]
|
||||||
|
|
|
@ -109,7 +109,7 @@ mainServe conf = do
|
||||||
initialize :: Conf -> IO (Settings,Application)
|
initialize :: Conf -> IO (Settings,Application)
|
||||||
initialize Conf{..} = do
|
initialize Conf{..} = do
|
||||||
uh <- newUserHandler userDBConf defaultAdminUser
|
uh <- newUserHandler userDBConf defaultAdminUser
|
||||||
ch <- newCommentHandler aggreactDB (dbstore uh) commentDBConf
|
ch <- newCommentHandler aggreactDB commentDBConf
|
||||||
sh <- newSlugHandler slugDBConf
|
sh <- newSlugHandler slugDBConf
|
||||||
ah <- newAuthorizationHandler authorizationStrategy
|
ah <- newAuthorizationHandler authorizationStrategy
|
||||||
myKey <- readKey jwtKeyFilePath
|
myKey <- readKey jwtKeyFilePath
|
||||||
|
|
|
@ -5,6 +5,7 @@
|
||||||
|
|
||||||
-- Common Pragmas (already stated in cabal file but repeated here for some tools)
|
-- Common Pragmas (already stated in cabal file but repeated here for some tools)
|
||||||
{-# LANGUAGE BlockArguments #-}
|
{-# LANGUAGE BlockArguments #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE NamedWildCards #-}
|
{-# LANGUAGE NamedWildCards #-}
|
||||||
|
|
|
@ -47,13 +47,9 @@ 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 as Beam
|
||||||
import qualified Database.Beam.Sqlite as BeamSqlite
|
import qualified Database.Beam.Sqlite as BeamSqlite
|
||||||
|
import Database.SQLite.Simple (Connection, query_)
|
||||||
import Database.Store (DefaultMetas (..), Id (..),
|
import Database.Store (DefaultMetas (..), Id (..),
|
||||||
Store (..))
|
Store (..))
|
||||||
import Database.Store.Backend.SQLite as SQL
|
import Database.Store.Backend.SQLite as SQL
|
||||||
|
@ -117,13 +113,13 @@ commentsView' conn db (Slug sl) = do
|
||||||
res <- BeamSqlite.runBeamSqliteDebug putStrLn conn $
|
res <- BeamSqlite.runBeamSqliteDebug putStrLn conn $
|
||||||
Beam.runSelectReturningList $ Beam.select $ do
|
Beam.runSelectReturningList $ Beam.select $ do
|
||||||
comment <- Beam.all_ (_aggreactComments db)
|
comment <- Beam.all_ (_aggreactComments db)
|
||||||
Beam.guard_ ((_slug comment) Beam.==. Beam.val_ sl)
|
Beam.guard_ (_slug comment Beam.==. Beam.val_ sl)
|
||||||
muser <- Beam.leftJoin_
|
muser <- Beam.leftJoin_
|
||||||
(Beam.all_ (_aggreactUsers db))
|
(Beam.all_ (_aggreactUsers db))
|
||||||
(\u -> (Beam.maybe_
|
(\u -> Beam.maybe_
|
||||||
(Beam.val_ False)
|
(Beam.val_ False)
|
||||||
(Beam.==. (User._id u))
|
(Beam.==. User._id u)
|
||||||
(_userid comment)))
|
(_userid comment))
|
||||||
pure (comment,muser)
|
pure (comment,muser)
|
||||||
traverse (\(c,mu) -> pure $
|
traverse (\(c,mu) -> pure $
|
||||||
CommentView
|
CommentView
|
||||||
|
@ -147,8 +143,11 @@ data CommentHandler = CommentHandler
|
||||||
|
|
||||||
-- | Init a new comment handler
|
-- | Init a new comment handler
|
||||||
-- newCommentHandler :: AggreactDB e -> User.DBStore -> CommentDBConf -> IO CommentHandler
|
-- 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 :: Beam.Database BeamSqlite.Sqlite db
|
||||||
newCommentHandler db userStore conf = do
|
=> AggreactDB (Beam.DatabaseEntity BeamSqlite.Sqlite db)
|
||||||
|
-> CommentDBConf
|
||||||
|
-> IO CommentHandler
|
||||||
|
newCommentHandler db conf = do
|
||||||
dbstore <- initDBComments conf
|
dbstore <- initDBComments conf
|
||||||
pure CommentHandler { createComment = createComment' dbstore
|
pure CommentHandler { createComment = createComment' dbstore
|
||||||
, readComment = readComment' dbstore
|
, readComment = readComment' dbstore
|
||||||
|
|
|
@ -52,7 +52,7 @@ where
|
||||||
|
|
||||||
import Protolude
|
import Protolude
|
||||||
|
|
||||||
import Aggreact.Users (User, UserId (..), BUserT)
|
import Aggreact.Users (User, UserId (..))
|
||||||
|
|
||||||
import qualified Control.Exception as Ex
|
import qualified Control.Exception as Ex
|
||||||
import Data.Aeson (FromJSON (..), ToJSON (..),
|
import Data.Aeson (FromJSON (..), ToJSON (..),
|
||||||
|
@ -140,15 +140,16 @@ bCommentToCommentNoUser :: BComment -> Comment
|
||||||
bCommentToCommentNoUser bc =
|
bCommentToCommentNoUser bc =
|
||||||
Entity
|
Entity
|
||||||
(Id (toS (_id bc)))
|
(Id (toS (_id bc)))
|
||||||
(NewComment
|
NewComment
|
||||||
{ parent = ParentId (fmap toS (_parent bc))
|
{ parent = ParentId (fmap toS (_parent bc))
|
||||||
, slug = Slug (_slug bc)
|
, slug = Slug (_slug bc)
|
||||||
, content = Content (_content bc)
|
, content = Content (_content bc)
|
||||||
, userid = MUserId Nothing
|
, userid = MUserId Nothing
|
||||||
})
|
}
|
||||||
(DefaultMetas
|
DefaultMetas
|
||||||
{ updated = _updated bc
|
{ updated = _updated bc
|
||||||
, created = _created bc })
|
, created = _created bc
|
||||||
|
}
|
||||||
|
|
||||||
data BCommentT f =
|
data BCommentT f =
|
||||||
BCommentT
|
BCommentT
|
||||||
|
|
|
@ -1,14 +1,15 @@
|
||||||
|
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE ImpredicativeTypes #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
{-# LANGUAGE ImpredicativeTypes #-}
|
|
||||||
|
|
||||||
{-# LANGUAGE BlockArguments #-}
|
{-# LANGUAGE BlockArguments #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
|
|
@ -34,8 +34,8 @@ import Protolude hiding (Handle)
|
||||||
import Control.Exception (bracket)
|
import Control.Exception (bracket)
|
||||||
|
|
||||||
class Service s a where
|
class Service s a where
|
||||||
type Config s a -- | the initial config a service should have
|
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 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)
|
init :: Proxy (Service s a) -> Config s a -> IO (Handle s a)
|
||||||
stop :: Proxy (Service s a) -> Handle s a -> IO ()
|
stop :: Proxy (Service s a) -> Handle s a -> IO ()
|
||||||
stop _ _ = pure ()
|
stop _ _ = pure ()
|
||||||
|
|
Loading…
Reference in a new issue