cleaning and read

.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}

src/Aggreact/Comments/Server.hs

@@ -79,9 +79,9 @@ commentAPI Handlers{..} authResult =
         _                    -> Nothing
   in
        showComments   muser authorizationHandler commentHandler
-  :<|> liftIO (getSlugs 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

src/Aggreact/Comments/StoreService.hs

@@ -11,17 +11,17 @@
 {-# 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,7 +39,7 @@ module Aggreact.Comments.StoreService
 where
 
 --------------------------------------------------------------------------------
-import           Protolude                        hiding (get, put)
+import           Protolude
 
 --------------------------------------------------------------------------------
 import           Aggreact.Comments.Types
@@ -50,7 +50,8 @@ 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
@@ -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,7 +138,7 @@ data CommentHandler = CommentHandler
 newCommentHandler :: User.DBStore -> CommentDBConf -> IO CommentHandler
 newCommentHandler userStore conf = do
   dbstore <- initDBComments conf
-  pure $ CommentHandler { createComment     = createComment' dbstore
+  pure CommentHandler { createComment     = createComment' dbstore
                       , readComment       = readComment' dbstore
                       , updateComment     = updateComment' dbstore
                       , deleteComment     = deleteComment' dbstore

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)
 

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

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

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