From c16e1f6962eb17eefa31745fcbcf7df227382d3b Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Mon, 18 Mar 2019 23:48:21 +0100 Subject: [PATCH] cleaning and read --- .hlint.yaml | 2 + src/Aggreact/Comments/Server.hs | 16 ++-- src/Aggreact/Comments/StoreService.hs | 103 +++++++++++++------------- src/Aggreact/Comments/Types.hs | 2 +- src/Aggreact/Comments/Views.hs | 38 +++++----- src/Database/Store.hs | 9 +++ src/Database/Store/Backend/SQLite.hs | 4 +- 7 files changed, 99 insertions(+), 75 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index e6c0252..5a321f1 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -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} diff --git a/src/Aggreact/Comments/Server.hs b/src/Aggreact/Comments/Server.hs index 8039eb7..d0382b6 100644 --- a/src/Aggreact/Comments/Server.hs +++ b/src/Aggreact/Comments/Server.hs @@ -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 diff --git a/src/Aggreact/Comments/StoreService.hs b/src/Aggreact/Comments/StoreService.hs index ca856c8..c0ba9a4 100644 --- a/src/Aggreact/Comments/StoreService.hs +++ b/src/Aggreact/Comments/StoreService.hs @@ -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 + } diff --git a/src/Aggreact/Comments/Types.hs b/src/Aggreact/Comments/Types.hs index 09c1acf..6f8ce6b 100644 --- a/src/Aggreact/Comments/Types.hs +++ b/src/Aggreact/Comments/Types.hs @@ -50,7 +50,7 @@ module Aggreact.Comments.Types where -import Protolude hiding (get, put) +import Protolude import Aggreact.User (User) diff --git a/src/Aggreact/Comments/Views.hs b/src/Aggreact/Comments/Views.hs index 2278437..ec7d3cd 100644 --- a/src/Aggreact/Comments/Views.hs +++ b/src/Aggreact/Comments/Views.hs @@ -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 diff --git a/src/Database/Store.hs b/src/Database/Store.hs index 4b033a7..daca4e5 100644 --- a/src/Database/Store.hs +++ b/src/Database/Store.hs @@ -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 diff --git a/src/Database/Store/Backend/SQLite.hs b/src/Database/Store/Backend/SQLite.hs index 1ad837f..f651dc0 100644 --- a/src/Database/Store/Backend/SQLite.hs +++ b/src/Database/Store/Backend/SQLite.hs @@ -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