yogsototh/aggreact
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

cleaning and read

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-03-18 23:48:21 +01:00
parent 7b9bb20dc6
commit c16e1f6962
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
7 changed files with 99 additions and 75 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.hlint.yaml
View file

@ -1,5 +1,7 @@
- ignore: {name: Use String}
- ignore: {name: Redundant id}
- ignore: {name: Evaluate}
- ignore: {name: Unused LANGUAGE pragma}
- warn: {lhs: identity x, rhs: x, side: not (isTypeApp x), name: Reduntant identity}
- error: {lhs: foldl x, rhs: foldl' x}
- error: {lhs: modifyTVar x, rhs: modifyTVar' x}

16
src/Aggreact/Comments/Server.hs
View file

@ -78,10 +78,10 @@ commentAPI Handlers{..} authResult =
(Authenticated user) -> Just user
_ -> Nothing
in
showComments muser authorizationHandler commentHandler
:<|> liftIO (getSlugs commentHandler)
showComments muser authorizationHandler commentHandler
:<|> showSlugs muser authorizationHandler commentHandler
:<|> postNewComment muser authorizationHandler commentHandler
:<|> showComment muser commentHandler
:<|> showComment muser authorizationHandler commentHandler
showComments :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler CommentsPage
showComments muser AuthorizationHandler{..} CommentHandler{..} s = do
@ -95,8 +95,14 @@ showComments muser AuthorizationHandler{..} CommentHandler{..} s = do
, muser = muser
}
showComment :: Maybe User -> CommentHandler -> Text -> Handler CommentPage
showComment muser CommentHandler{..} i =
showSlugs :: Maybe User -> AuthorizationHandler -> CommentHandler -> Handler [Slug]
showSlugs muser AuthorizationHandler{..} ch = do
_ <- checkAccess (Scope "comment" Read) muser
liftIO (getSlugs ch)
showComment :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler CommentPage
showComment muser AuthorizationHandler{..} CommentHandler{..} i = do
_ <- checkAccess (Scope "comment" Read) muser
case UUID.fromText i of
Nothing -> notFound ""
Just uuid -> do

103
src/Aggreact/Comments/StoreService.hs
View file

@ -1,27 +1,27 @@
-- Local Pragmas
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- Common Pragmas (already stated in cabal file but repeated here for some tools)
{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ...
{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies
{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b
{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _
{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example
{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000
{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set
{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type
{-# LANGUAGE PartialTypeSignatures #-} -- write foo :: (_) => a -> Bool
{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ...
{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE NamedWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module : Aggreact.Comments.StoreService
Description : CommentStore service
@ -39,23 +39,24 @@ module Aggreact.Comments.StoreService
where
--------------------------------------------------------------------------------
import Protolude hiding (get, put)
import Protolude
--------------------------------------------------------------------------------
import Aggreact.Comments.Types
import qualified Aggreact.User as User
import Aggreact.Comments.Types
import qualified Aggreact.User as User
--------------------------------------------------------------------------------
import Data.Time.Clock.Serialize ()
import Data.Time.Format ()
import Database.SQLite.Simple (Only (..), query, query_)
import Data.Time.Clock.Serialize ()
import Data.Time.Format ()
import Database.SQLite.Simple (Only (..), query, query_)
import Database.Store (DefaultMetas (..), Id (..), Store (..))
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 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
@ -88,20 +89,22 @@ searchComments' = Search.search
-- ** Specific queries
getSlugs' :: DBStore -> IO [Slug]
getSlugs' SQLiteState{..} =
liftIO $ query_ conn (conv ("SELECT DISTINCT slug FROM " <> stTablename <> " ORDER BY created LIMIT 100"))
getSlugs' SQLiteState{..} = liftIO . query_ conn . conv $
"SELECT DISTINCT slug FROM " <> stTablename <> " ORDER BY created LIMIT 100"
getTopSlugs' :: DBStore -> IO [(Slug,Int)]
getTopSlugs' SQLiteState{..} =
liftIO $ query_ conn (conv ("SELECT slug,COUNT(id) FROM " <> stTablename <> " GROUP BY slug ORDER BY COUNT(id) DESC LIMIT 100"))
getTopSlugs' SQLiteState{..} = liftIO . query_ conn . conv $
"SELECT slug,COUNT(id) FROM " <> stTablename
<> " GROUP BY slug ORDER BY COUNT(id) DESC LIMIT 100"
getLatestSlugs' :: DBStore -> IO [(Slug,Int)]
getLatestSlugs' SQLiteState{..} =
liftIO $ query_ conn (conv ("SELECT DISTINCT slug,COUNT(id) FROM " <> stTablename <> " GROUP BY slug ORDER BY created DESC LIMIT 100"))
getLatestSlugs' SQLiteState{..} = liftIO . query_ conn . conv $
"SELECT DISTINCT slug,COUNT(id) FROM " <> stTablename
<> " GROUP BY slug ORDER BY created DESC LIMIT 100"
getLatestComments' :: DBStore -> IO [Comment]
getLatestComments' SQLiteState{..} =
liftIO $ query_ conn (conv ("SELECT * FROM " <> stTablename <> " ORDER BY created DESC LIMIT 20"))
getLatestComments' SQLiteState{..} = liftIO . query_ conn . conv $
"SELECT * FROM " <> stTablename <> " ORDER BY created DESC LIMIT 20"
commentsView' :: User.DBStore -> DBStore -> Slug -> IO [CommentView]
commentsView' userStore commentStore sl = do
@ -135,15 +138,15 @@ data CommentHandler = CommentHandler
newCommentHandler :: User.DBStore -> CommentDBConf -> IO CommentHandler
newCommentHandler userStore conf = do
dbstore <- initDBComments conf
pure $ CommentHandler { createComment = createComment' dbstore
, readComment = readComment' dbstore
, updateComment = updateComment' dbstore
, deleteComment = deleteComment' dbstore
, searchComments = searchComments' dbstore
, stopDBComments = stopDBComments' dbstore
, getSlugs = getSlugs' dbstore
, getTopSlugs = getTopSlugs' dbstore
, getLatestSlugs = getLatestSlugs' dbstore
, getLatestComments = getLatestComments' dbstore
, commentsView = commentsView' userStore dbstore
}
pure CommentHandler { createComment = createComment' dbstore
, readComment = readComment' dbstore
, updateComment = updateComment' dbstore
, deleteComment = deleteComment' dbstore
, searchComments = searchComments' dbstore
, stopDBComments = stopDBComments' dbstore
, getSlugs = getSlugs' dbstore
, getTopSlugs = getTopSlugs' dbstore
, getLatestSlugs = getLatestSlugs' dbstore
, getLatestComments = getLatestComments' dbstore
, commentsView = commentsView' userStore dbstore
}

2
src/Aggreact/Comments/Types.hs
View file

@ -50,7 +50,7 @@ module Aggreact.Comments.Types
where
import Protolude hiding (get, put)
import Protolude
import Aggreact.User (User)

38
src/Aggreact/Comments/Views.hs
View file

@ -38,7 +38,7 @@ module Aggreact.Comments.Views
where
--------------------------------------------------------------------------------
import Protolude hiding (get, put)
import Protolude
--------------------------------------------------------------------------------
import Aggreact.Comments.Types
@ -172,6 +172,22 @@ displayOneComment comment vt = do
H.pre $ H.text (toS (content (val comment)))
H.a ! A.href (cvt ("/comment/" <> cid)) ! A.class_ "small" $ "reply"
displayTime :: UTCTime -> Entity DefaultMetas a -> H.Html
displayTime vt comment = H.span ! A.class_ "time" $ do
H.text " - "
H.text . toS . approximativeDuration . realToFrac $ diffUTCTime vt (created (metas comment))
H.text " ago"
displayHidingBlock :: ( StringConv a [Char]
, Semigroup a
, IsString a)
=> a -> Entity ms NewComment -> H.Markup -> H.Html
displayHidingBlock cid comment children =
H.div ! A.class_ "tohide" $ do
H.pre $ comment & val & content & toS & H.text
H.a ! A.href (cvt ("/comment/" <> cid)) ! A.class_ "small" $ "reply"
children
displayCommentView :: CommentView -> UTCTime -> H.Markup -> H.Markup
displayCommentView (CommentView comment user) vt children = do
let inputid = "toggle-" <> UUID.toString (toS (id comment))
@ -182,14 +198,8 @@ displayCommentView (CommentView comment user) vt children = do
H.label ! A.for (cvt inputid) ! A.class_ "togglelabel" $ H.span (H.text "[-]")
H.a ! A.href (cvt ('#':cid)) $ "§ "
H.a ! A.href (cvt ("/user/" <> urlEncode (toS (id user)))) $ H.text (toS (nick (val user)))
H.span ! A.class_ "time" $ do
H.text " - "
H.text . toS . approximativeDuration . realToFrac $ diffUTCTime vt (created (metas comment))
H.text " ago"
H.div ! A.class_ "tohide" $ do
H.pre $ H.text (toS (content (val comment)))
H.a ! A.href (cvt ("/comment/" <> cid)) ! A.class_ "small" $ "reply"
children
displayTime vt comment
displayHidingBlock cid comment children
displayComment :: Comment -> UTCTime -> H.Markup -> H.Markup
displayComment comment vt children = do
@ -200,11 +210,5 @@ displayComment comment vt children = do
H.div ! A.id (cvt cid) ! A.class_ "metas" $ do
H.label ! A.for (cvt inputid) ! A.class_ "togglelabel" $ H.span (H.text "[-]")
H.a ! A.href (cvt ('#':cid)) $ "§ "
H.span ! A.class_ "time" $ do
H.text " - "
H.text . toS . approximativeDuration . realToFrac $ diffUTCTime vt (created (metas comment))
H.text " ago"
H.div ! A.class_ "tohide" $ do
H.pre $ H.text (toS (content (val comment)))
H.a ! A.href (cvt ("/comment/" <> cid)) ! A.class_ "small" $ "reply"
children
displayTime vt comment
displayHidingBlock cid comment children

9
src/Database/Store.hs
View file

@ -68,6 +68,7 @@ import qualified Data.UUID as UUID
import qualified Generics.SOP as SOP
import Servant.Auth.Server (FromJWT, ToJWT)
import qualified Web.HttpApiData as FormI
import qualified Service.Service as Serv
-- | This is the ID type, it is like @Text@.
instance StringConv UUID [Char] where strConv l = strConv l . UUID.toString
@ -138,6 +139,14 @@ deriving instance (FromJSON ms, FromJSON a) => FromJSON (Entity ms a)
deriving instance (FromJSON ms, FromJWT ms, FromJSON a, FromJWT a) => FromJWT (Entity ms a)
deriving instance (ToJSON ms, ToJWT ms, ToJSON a, ToJWT a) => ToJWT (Entity ms a)
-- data StoreService store metas entity
-- data family StoreConfig store
-- data family StoreHandler store
--
-- instance Serv.Service (StoreService store metas entity) b where
-- type Config (StoreService store metas entity) b = StoreConfig store
-- type Handle (StoreService store metas entity) b = StoreHandler store
class Store store m metas entity | store -> m metas entity where
data DBConf store
data StartedStore store

4
src/Database/Store/Backend/SQLite.hs
View file

@ -236,8 +236,8 @@ instance ( MonadIO m
conn <- liftIO $ open (toS dbfilepath)
let q :: Query = fromString . toS $ "CREATE TABLE IF NOT EXISTS " <> tablename <> " (" <> sqlSchemaTxt (Proxy :: Proxy (Entity ms a)) <> ")"
void . liftIO $ execute_ conn q
return (SQLiteState { conn = conn
, stTablename = tablename })
return SQLiteState { conn = conn
, stTablename = tablename }
stop = liftIO . close . conn
instance ( CRUD.CRUDMetas m ms