diff --git a/aggreact.cabal b/aggreact.cabal index 994a67e..58fbcb5 100644 --- a/aggreact.cabal +++ b/aggreact.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: ffbf5cf45e9828aaa0ada5427256e10f89a060d93ec2e7d80d807ac2bb72d2b3 +-- hash: b25d763a18f7abd2dd41f84f6e8923a72cfbde56ee75daf4de8e5c10a24b3c19 name: aggreact version: 0.1.0.0 @@ -29,6 +29,9 @@ library exposed-modules: Aggreact Aggreact.Comments + Aggreact.Comments.StoreService + Aggreact.Comments.Types + Aggreact.Comments.Views Aggreact.Css Aggreact.Homepage Aggreact.Html @@ -41,6 +44,8 @@ library Generics.SOP.Fieldnames Servant.Clay Servant.Errors + Service.Config + Service.Service other-modules: Paths_aggreact hs-source-dirs: @@ -57,6 +62,8 @@ library , cereal-time , clay , containers + , dhall + , filepath , foreign-store , generics-sop , http-api-data @@ -78,6 +85,7 @@ library , uuid , wai , warp + , yaml default-language: Haskell2010 executable aggreact diff --git a/dev.dhall b/dev.dhall new file mode 100644 index 0000000..46cf01f --- /dev/null +++ b/dev.dhall @@ -0,0 +1,14 @@ +{- + +Aggreact Configuration File + +-} +let SQLiteConfig : Type = { filepath : Text } + +let PostgresConfig + : Type + = { host : Text, port : Natural, user : Text, password : Text } + +let DBConf : Type = < SQLite : SQLiteConfig | Postgre : PostgresConfig > + +in { port = 3000, db = DBConf.SQLite { filepath = "aggreact.db" } } \ No newline at end of file diff --git a/package.yaml b/package.yaml index 12f70a8..deb8197 100644 --- a/package.yaml +++ b/package.yaml @@ -10,22 +10,21 @@ extra-source-files: - README.md - stack.yaml default-extensions: - - OverloadedStrings # write "foo" and it will be the correct text type - - NoImplicitPrelude # to use protolude for example - - ScopedTypeVariables # write expr :: Type inside an expression - - TupleSections # (a,,) instead of \x y -> (a,x,y) - - OverloadedLists # write [1,2,3] :: Set - - ExplicitForAll # f :: forall a b. a -> b -> b - - RecordWildCards # f Conf{..} = field1 ... + - OverloadedStrings # write "foo" and it will be the correct text type + - NoImplicitPrelude # to use protolude for example + - ScopedTypeVariables # write expr :: Type inside an expression + - TupleSections # (a,,) instead of \x y -> (a,x,y) + - OverloadedLists # write [1,2,3] :: Set + - ExplicitForAll # f :: forall a b. a -> b -> b + - RecordWildCards # f Conf{..} = field1 ... - GeneralizedNewtypeDeriving # newtype Id = Id Text deriving (StringConv Id String) - - DeriveGeneric # deriving ToJSON ... - - DerivingStrategies # remove warn about deriving strategies - - StandaloneDeriving # write deriving instance ... - # need GHC > 8.6 - - NamedWildCards # can use _type instead of just _ - - PartialTypeSignatures - - BlockArguments # blabla do ... instead of blabla $ do ... - - NumericUnderscores # write 1_000 instead of 1000 + - DeriveGeneric # deriving ToJSON ... + - DerivingStrategies # remove warn about deriving strategies + - StandaloneDeriving # write deriving instance ... + - NamedWildCards # can use _type instead of just _ + - PartialTypeSignatures # write foo :: (_) => a -> Bool + - BlockArguments # blabla do ... instead of blabla $ do ... + - NumericUnderscores # write 1_000 instead of 1000 ghc-options: - -Wall - -Wcompat @@ -48,6 +47,8 @@ library: - cereal-time - clay - containers + - dhall + - filepath - foreign-store - http-api-data - http-media @@ -68,6 +69,7 @@ library: - uuid - wai - warp + - yaml executables: aggreact: main: Main.hs diff --git a/src/Aggreact.hs b/src/Aggreact.hs index f02e7a7..333efcd 100644 --- a/src/Aggreact.hs +++ b/src/Aggreact.hs @@ -43,6 +43,7 @@ module Aggreact import Protolude import Aggreact.Comments +import Aggreact.Html import Aggreact.Css (genCss) import Aggreact.Homepage import Aggreact.User @@ -88,11 +89,12 @@ instance Form.FromForm Login where type Unprotected = "login" - :> ReqBody '[JSON, FormUrlEncoded] Login - :> PostNoContent '[JSON, FormUrlEncoded] - (Headers '[ Header "Set-Cookie" SetCookie - , Header "Set-Cookie" SetCookie] - NoContent) + :> (ReqBody '[JSON, FormUrlEncoded] Login + :> PostNoContent '[JSON, FormUrlEncoded] + (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie] + NoContent) + :<|> Get '[HTML] LoginPage) type API auths = (Servant.Auth.Server.Auth auths User :> CommentAPI) :<|> Unprotected @@ -108,6 +110,7 @@ server :: Settings -> Server (API auths) server settings@Settings{..} = commentAPI settings :<|> checkCreds settings + :<|> return LoginPage mainServe :: Conf -> IO () mainServe conf = do @@ -120,13 +123,6 @@ checkCreds :: Settings -> Handler (Headers '[ Header "Set-Cookie" SetCookie , Header "Set-Cookie" SetCookie] NoContent) --- checkCreds Settings{..} (Login "admin" "admin") = do --- mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings adminUser --- putText "Admin Login" --- case mApplyCookies of --- Nothing -> unauthorized "Could not create a cookie" --- Just applyCookies -> return $ applyCookies NoContent - checkCreds Settings{..} (Login loginNick loginPass) = do muser <- liftIO $ checkUserLogin userHandler loginNick loginPass case muser of diff --git a/src/Aggreact/Comments.hs b/src/Aggreact/Comments.hs index 9c2f65f..16389c3 100644 --- a/src/Aggreact/Comments.hs +++ b/src/Aggreact/Comments.hs @@ -1,31 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} - -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} {- | Module : Aggreact.Comments Description : Example of a library file. @@ -58,442 +30,7 @@ module Aggreact.Comments , displayOneComment ) where -import Protolude hiding (get, put) +import Aggreact.Comments.StoreService +import Aggreact.Comments.Types +import Aggreact.Comments.Views -import Aggreact.Html (boilerplate, loginWidget, - urlEncode) -import Aggreact.User (NewUser (..), User) -import qualified Aggreact.User as User - -import qualified Control.Exception as Ex -import Data.Aeson (FromJSON (..), ToJSON (..), - defaultOptions, - genericParseJSON, - genericToJSON) -import Data.Char (isAlphaNum) -import Data.Data (Data (..)) -import Data.Duration (approximativeDuration) -import qualified Data.IxSet.Typed as IxSet -import Data.String (IsString (..)) -import qualified Data.Text as Text -import Data.Time (UTCTime, diffUTCTime) -import Data.Time.Clock.Serialize () -import Data.Time.Format () -import Data.Typeable (Typeable) -import Data.UUID (UUID) -import qualified Data.UUID as UUID -import Database.SQLite.Simple (Only (..), SQLData (..), - query, query_) -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.FromRow (FromRow (..), field) -import Database.SQLite.Simple.ToField (ToField (..)) -import Database.SQLite.Simple.ToRow (ToRow (..)) -import Database.Store (DefaultMetas (..), - Entity (..), 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 Generics.SOP as SOP -import Text.Blaze.Html5 ((!)) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A -import qualified Web.FormUrlEncoded as Form -import qualified Web.HttpApiData as FormI - -{- * Structure - -Each entity should have the following properties: - -* provide a type that represent the internal structure @Struct@ -* provide a type that represent the metas structure @Metas@ -* @Entity Metas Struct@ should be an instance of some Backend Store typeclass -* @Entity Metas Struct@ should be an instance of 'ToJSON' -* @Metas@ should be an instance of 'FromJSON', 'FromForm' and mainly one for all - content-type you like - --} - --- * Comments - -instance ( Ord a - , ToJSON a - , IxSet.Indexable ixs a - , Typeable a) => ToJSON (IxSet.IxSet ixs a) where - toJSON i = toJSON (IxSet.toList i) - --- * Comment - -data DecodeUUIDException = DecodeUUIDException deriving (Show) -instance Ex.Exception DecodeUUIDException - -newtype ParentId = ParentId (Maybe UUID) deriving (Eq,Ord,Show,Generic,Data) -deriving anyclass instance FromJSON ParentId -deriving anyclass instance ToJSON ParentId -instance ToField UUID where - toField = SQLText . UUID.toText -deriving newtype instance ToField ParentId -deriving newtype instance FromField ParentId -instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (ParentId ': rest) where - toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) - -newtype Slug = Slug Text deriving (Eq,Ord,Show,Generic,Data) -instance StringConv Slug [Char] where strConv l (Slug sl) = strConv l sl -instance StringConv Slug Text where strConv l (Slug sl) = strConv l sl -deriving anyclass instance FromJSON Slug -deriving anyclass instance ToJSON Slug -deriving newtype instance ToField Slug -deriving newtype instance FromField Slug -instance FromRow Slug where fromRow = Slug <$> field -instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Slug ': rest) where - toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) - -newtype UserId = UserId Text deriving (Eq,Ord,Show,Generic,Data) -instance StringConv UserId [Char] where strConv l (UserId sl) = strConv l sl -instance StringConv UserId Text where strConv l (UserId sl) = strConv l sl -deriving anyclass instance FromJSON UserId -deriving anyclass instance ToJSON UserId -deriving newtype instance FromField UserId -deriving newtype instance ToField UserId -instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (UserId ': rest) where - toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) - -newtype Content = Content Text deriving (Eq,Ord,Show,Generic,Data) -instance StringConv Content [Char] where strConv l (Content sl) = strConv l sl -instance StringConv Content Text where strConv l (Content sl) = strConv l sl -deriving anyclass instance FromJSON Content -deriving anyclass instance ToJSON Content -deriving newtype instance FromField Content -deriving newtype instance ToField Content -instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Content ': rest) where - toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) - -newtype Term = Term Text deriving (Eq,Ord,Generic) - -data NewComment = - NewComment - { parent :: ParentId - , slug :: Slug - , content :: Content - , userid :: UserId - } deriving (Generic,Typeable,Data,Eq,Ord,Show) - -instance FromJSON NewComment where - parseJSON = genericParseJSON defaultOptions -instance ToJSON NewComment where - toJSON = genericToJSON defaultOptions - -instance FormI.FromHttpApiData ParentId where - parseUrlPiece s = do - txt <- FormI.parseUrlPiece s - if Text.null txt - then return (ParentId Nothing) - else case UUID.fromText txt of - Nothing -> Left $ "Parent ID is not an UUID (" <> txt <> ")" - Just uuid -> return (ParentId (Just uuid)) -instance FormI.FromHttpApiData Slug where parseUrlPiece = fmap Slug . FormI.parseUrlPiece -instance FormI.FromHttpApiData Content where parseUrlPiece = fmap Content . FormI.parseUrlPiece -instance FormI.FromHttpApiData UserId where parseUrlPiece = fmap UserId . FormI.parseUrlPiece -instance Form.FromForm NewComment where - fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity} - - -type NewCommentIxs = '[ParentId,Slug,Content,UserId,Term] -instance IxSet.Indexable NewCommentIxs Comment where - indices = IxSet.ixList - (IxSet.ixGen (Proxy :: Proxy ParentId)) - (IxSet.ixGen (Proxy :: Proxy Slug)) - (IxSet.ixGen (Proxy :: Proxy Content)) - (IxSet.ixGen (Proxy :: Proxy UserId)) - (IxSet.ixFun getTerms) - -type Comment = Entity DefaultMetas NewComment -type CommentIxs = '[Id,ParentId,Slug,Content,UserId,Term] -instance IxSet.Indexable CommentIxs Comment where - indices = IxSet.ixList - (IxSet.ixGen (Proxy :: Proxy Id)) - (IxSet.ixGen (Proxy :: Proxy ParentId)) - (IxSet.ixGen (Proxy :: Proxy Slug)) - (IxSet.ixGen (Proxy :: Proxy Content)) - (IxSet.ixGen (Proxy :: Proxy UserId)) - (IxSet.ixFun getTerms) - -type Comments = IxSet.IxSet CommentIxs Comment - -data CommentView = CommentView Comment User deriving (Eq,Ord,Data,Typeable,Generic,Show) -deriving instance ToJSON CommentView -instance FromRow CommentView where fromRow = CommentView <$> fromRow <*> fromRow - -type CommentViews = IxSet.IxSet CommentViewIxs CommentView -type CommentViewIxs = '[Id,ParentId,Slug,Content,UserId,Term] -instance IxSet.Indexable CommentViewIxs CommentView where - indices = IxSet.ixList - (IxSet.ixFun (\(CommentView c _) -> [id c])) - (IxSet.ixGen (Proxy :: Proxy ParentId)) - (IxSet.ixGen (Proxy :: Proxy Slug)) - (IxSet.ixGen (Proxy :: Proxy Content)) - (IxSet.ixGen (Proxy :: Proxy UserId)) - (IxSet.ixFun (\(CommentView c _) -> getTerms c)) - -getTerms :: Comment -> [Term] -getTerms = fmap Term . Text.split (not . isAlphaNum) . unContent . content . val - where unContent (Content x) = x - --- * Operations - -data CommentPage = - CommentPage - { commentPageUrl :: Text - , commentPageViewTime :: UTCTime - , commentPageComment :: Comment - , muser :: Maybe User - } -instance ToJSON CommentPage where - toJSON cp = toJSON (commentPageComment cp) - --- | helper for conversions -cvt :: StringConv a [Char] => a -> H.AttributeValue -cvt = fromString . toS - -extlink :: StringConv a [Char] => a -> Text -> H.Html -extlink url txt = H.a - ! A.href (cvt url) - ! A.target "_blank" - ! A.rel "noopener noreferrer nofollow" - $ do - H.text txt - H.sup $ H.text "⬀" - -instance H.ToMarkup CommentPage where - toMarkup CommentPage{..} = boilerplate (loginWidget muser) $ do - let sl = commentPageComment & val & slug & toS - cid = commentPageUrl - H.h2 $ do - H.a ! A.href ("/comments/" <> cvt (urlEncode (toS sl)) <> "#" <> cvt cid) $ H.text "Comment" - H.text " for " - extlink sl sl - displayComment commentPageComment commentPageViewTime (pure ()) - commentForm sl "anonymous coward" (Just (cvt cid)) - - -data CreatedComment = - CreatedComment - { viewTime :: UTCTime - , comment :: Comment - , muser :: Maybe User - } -instance ToJSON CreatedComment where - toJSON cp = toJSON (comment cp) - -commentLink :: Comment -> H.Html -commentLink c = do - let s = slug (val c) - i = id c - url = toS ("/comments/" <> urlEncode (toS s) <> "#" <> toS i) - H.a ! A.href (fromString url) - $ H.text (toS s) - -instance H.ToMarkup CreatedComment where - toMarkup CreatedComment{..} = - boilerplate (loginWidget muser) $ do - H.h2 $ do - H.text "Comments for " - commentLink comment - displayOneComment comment viewTime - -data CommentsPage = - CommentsPage - { url :: Text - , viewTime :: UTCTime - , comments :: CommentViews - , muser :: Maybe User - } - -instance ToJSON CommentsPage where - toJSON cp = toJSON (comments cp) - -instance H.ToMarkup CommentsPage where - toMarkup CommentsPage{..} = do - let roots = comments IxSet.@= ParentId Nothing - boilerplate (loginWidget muser) $ do - H.h2 $ do - H.text "Comments for " - H.a ! A.href (cvt url) $ H.text url - commentForm url "anonymous coward" Nothing - H.ul $ traverse_ (showChildren comments viewTime) (IxSet.toList roots) - -commentForm :: StringConv a [Char] => a -> H.AttributeValue -> Maybe H.AttributeValue -> H.Html -commentForm slug user mparent = - H.form ! A.action "/comments" ! A.method "post" $ do - H.input ! A.type_ "hidden" ! A.name "userid" ! A.value user - H.input ! A.type_ "hidden" ! A.name "parent" ! A.value (fromMaybe "" mparent) - H.input ! A.type_ "hidden" ! A.name "slug" ! A.value (cvt slug) - (H.textarea ! A.name "content" ! A.rows "6" ! A.cols "60" ! A.maxlength "5000") "" - H.br - H.input ! A.type_ "submit" ! A.value "add comment" - -showChildren :: CommentViews -> UTCTime -> CommentView -> H.Markup -showChildren cvs vt cv@(CommentView comment _) = H.li $ - displayCommentView cv vt $ do - let children = cvs IxSet.@= ParentId (Just (toS (id comment))) - if IxSet.null children - then return () - else H.ul $ traverse_ (showChildren cvs vt) (IxSet.toList children) - -displayOneComment :: Comment -> UTCTime -> H.Markup -displayOneComment comment vt = do - let inputid = "toggle-" <> UUID.toString (toS (id comment)) - H.input ! A.type_ "checkbox" ! A.class_ "toggleinput" ! A.id (cvt inputid) - H.div $ do - let cid = UUID.toString (toS (id comment)) - s = slug (val comment) - 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.a H.! A.href (fromString (toS ("/comments/" <> urlEncode (toS s)))) $ H.text (toS s) - H.text " - " - H.text (toS (userid (val comment))) - 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" - -displayCommentView :: CommentView -> UTCTime -> H.Markup -> H.Markup -displayCommentView (CommentView comment user) vt children = do - let inputid = "toggle-" <> UUID.toString (toS (id comment)) - H.input ! A.type_ "checkbox" ! A.class_ "toggleinput" ! A.id (cvt inputid) - H.div $ do - let cid = UUID.toString (toS (id comment)) - 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.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 - -displayComment :: Comment -> UTCTime -> H.Markup -> H.Markup -displayComment comment vt children = do - let inputid = "toggle-" <> UUID.toString (toS (id comment)) - H.input ! A.type_ "checkbox" ! A.class_ "toggleinput" ! A.id (cvt inputid) - H.div $ do - let cid = UUID.toString (toS (id comment)) - 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 - -instance SOP.Generic NewComment -instance SOP.HasDatatypeInfo NewComment -deriving instance SQLiteSchemas NewComment - -instance FromRow NewComment where fromRow = SQL.genericFromRow - -instance ToRow NewComment where toRow = SQL.genericToRow - --- * Usage for DB - -type CommentSQLiteStore = SQLiteStore IO DefaultMetas NewComment -type DBStore = StartedStore CommentSQLiteStore -type CommentDBConf = DBConf CommentSQLiteStore -type CommentSearchQuery = Search.SearchQuery CommentSQLiteStore -type CommentSearchResult = Search.SearchResult CommentSQLiteStore - -initDBComments :: CommentDBConf -> IO DBStore -initDBComments = init - -stopDBComments' :: DBStore -> IO () -stopDBComments' = stop - -createComment' :: DBStore -> NewComment -> IO Comment -createComment' = CRUD.create - -readComment' :: DBStore -> Id -> IO (Maybe Comment) -readComment' = CRUD.read - -updateComment' :: DBStore -> Id -> NewComment -> IO (Maybe Comment) -updateComment' = CRUD.update - -deleteComment' :: DBStore -> Id -> IO Bool -deleteComment' = CRUD.delete - -searchComments' :: DBStore -> CommentSearchQuery -> IO CommentSearchResult -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")) - -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")) - -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")) - -getLatestComments' :: DBStore -> IO [Comment] -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 - let queryTxt = "SELECT * FROM " - <> stTablename commentStore <> " c" - <> " INNER JOIN " - <> stTablename userStore <> " u" - <> " ON c.userid = u.id" - <> " WHERE " - <> " slug = ? " - <> " ORDER BY created" - <> " DESC LIMIT 1000" - liftIO $ query (conn commentStore) (conv queryTxt) (Only sl) - --- | A comment handler, handle all impure operations needed to Comments -data CommentHandler = CommentHandler - { createComment :: NewComment -> IO Comment - , readComment :: Id -> IO (Maybe Comment) - , updateComment :: Id -> NewComment -> IO (Maybe Comment) - , deleteComment :: Id -> IO Bool - , searchComments :: CommentSearchQuery -> IO CommentSearchResult - , stopDBComments :: IO () - , getSlugs :: IO [Slug] - , getTopSlugs :: IO [(Slug,Int)] - , getLatestSlugs :: IO [(Slug,Int)] - , getLatestComments :: IO [Comment] - , commentsView :: Slug -> IO [CommentView] - } - --- | Init a new comment handler -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 - } diff --git a/src/Aggreact/Comments/StoreService.hs b/src/Aggreact/Comments/StoreService.hs new file mode 100644 index 0000000..06370b1 --- /dev/null +++ b/src/Aggreact/Comments/StoreService.hs @@ -0,0 +1,154 @@ +-- 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 #-} + +-- 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 +{- | +Module : Aggreact.Comments.StoreService +Description : CommentStore service +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Comment datastructures with class instances + + +- A @Comment@ is a NewComment with metas +- A @CommentView@ is a comment along its creator infos +- A @NewComment@ is the main infos for a Comment + +-} + +module Aggreact.Comments.StoreService +where + +-------------------------------------------------------------------------------- +import Protolude hiding (get, put) + +-------------------------------------------------------------------------------- +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 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 +type CommentDBConf = DBConf CommentSQLiteStore +type CommentSearchQuery = Search.SearchQuery CommentSQLiteStore +type CommentSearchResult = Search.SearchResult CommentSQLiteStore + +initDBComments :: CommentDBConf -> IO DBStore +initDBComments = init + +stopDBComments' :: DBStore -> IO () +stopDBComments' = stop + +createComment' :: DBStore -> NewComment -> IO Comment +createComment' = CRUD.create + +readComment' :: DBStore -> Id -> IO (Maybe Comment) +readComment' = CRUD.read + +updateComment' :: DBStore -> Id -> NewComment -> IO (Maybe Comment) +updateComment' = CRUD.update + +deleteComment' :: DBStore -> Id -> IO Bool +deleteComment' = CRUD.delete + +searchComments' :: DBStore -> CommentSearchQuery -> IO CommentSearchResult +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")) + +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")) + +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")) + +getLatestComments' :: DBStore -> IO [Comment] +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 + let queryTxt = "SELECT * FROM " + <> stTablename commentStore <> " c" + <> " INNER JOIN " + <> stTablename userStore <> " u" + <> " ON c.userid = u.id" + <> " WHERE " + <> " slug = ? " + <> " ORDER BY created" + <> " DESC LIMIT 1000" + liftIO $ query (conn commentStore) (conv queryTxt) (Only sl) + +-- | A comment handler, handle all impure operations needed to Comments +data CommentHandler = CommentHandler + { createComment :: NewComment -> IO Comment + , readComment :: Id -> IO (Maybe Comment) + , updateComment :: Id -> NewComment -> IO (Maybe Comment) + , deleteComment :: Id -> IO Bool + , searchComments :: CommentSearchQuery -> IO CommentSearchResult + , stopDBComments :: IO () + , getSlugs :: IO [Slug] + , getTopSlugs :: IO [(Slug,Int)] + , getLatestSlugs :: IO [(Slug,Int)] + , getLatestComments :: IO [Comment] + , commentsView :: Slug -> IO [CommentView] + } + +-- | Init a new comment handler +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 + } diff --git a/src/Aggreact/Comments/Types.hs b/src/Aggreact/Comments/Types.hs new file mode 100644 index 0000000..7af5cb9 --- /dev/null +++ b/src/Aggreact/Comments/Types.hs @@ -0,0 +1,228 @@ +-- Local Pragmas +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# 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 DeriveGeneric #-} -- deriving ToJSON ... +{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies +{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- newtype Id = Id Text deriving (StringConv Id String) +{-# 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 StandaloneDeriving #-} -- write deriving instance ... +{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y) +{- | +Module : Aggreact.Comments.StoreService +Description : CommentStore service +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Comment datastructures with class instances + + +- A @Comment@ is a NewComment with metas +- A @CommentView@ is a comment along its creator infos +- A @NewComment@ is the main infos for a Comment + +-} + +module Aggreact.Comments.Types +where + + +import Protolude hiding (get, put) + +import Aggreact.User (User) + +import qualified Control.Exception as Ex +import Data.Aeson (FromJSON (..), ToJSON (..), + defaultOptions, + genericParseJSON, + genericToJSON) +import Data.Char (isAlphaNum) +import Data.Data (Data (..)) +import qualified Data.IxSet.Typed as IxSet +import qualified Data.Text as Text +import Data.Time.Clock.Serialize () +import Data.Time.Format () +import Data.Typeable (Typeable) +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import Database.SQLite.Simple (SQLData (..)) +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.FromRow (FromRow (..), field) +import Database.SQLite.Simple.ToRow (ToRow (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +import Database.Store (DefaultMetas (..), Entity (..), Id (..)) +import Database.Store.Backend.SQLite as SQL +import qualified Generics.SOP as SOP +import qualified Web.FormUrlEncoded as Form +import qualified Web.HttpApiData as FormI + + +-- * Comment + +-- | A Comment is a NewComment with metas +type Comment = Entity DefaultMetas NewComment + +-- Comment Indexing +type Comments = IxSet.IxSet CommentIxs Comment +type CommentIxs = '[Id,ParentId,Slug,Content,UserId,Term] +instance IxSet.Indexable CommentIxs Comment where + indices = IxSet.ixList + (IxSet.ixGen (Proxy :: Proxy Id)) + (IxSet.ixGen (Proxy :: Proxy ParentId)) + (IxSet.ixGen (Proxy :: Proxy Slug)) + (IxSet.ixGen (Proxy :: Proxy Content)) + (IxSet.ixGen (Proxy :: Proxy UserId)) + (IxSet.ixFun getTerms) + +-- ** CommentView + +-- | A CommentView is a comment along its creator infos +data CommentView = CommentView Comment User + deriving (Eq,Ord,Data,Typeable,Generic,Show) + +-- Web +deriving instance ToJSON CommentView +-- SQLite Select +instance FromRow CommentView where fromRow = CommentView <$> fromRow <*> fromRow +-- Indexing +type CommentViews = IxSet.IxSet CommentViewIxs CommentView +type CommentViewIxs = '[Id,ParentId,Slug,Content,UserId,Term] +instance IxSet.Indexable CommentViewIxs CommentView where + indices = IxSet.ixList + (IxSet.ixFun (\(CommentView c _) -> [id c])) + (IxSet.ixGen (Proxy :: Proxy ParentId)) + (IxSet.ixGen (Proxy :: Proxy Slug)) + (IxSet.ixGen (Proxy :: Proxy Content)) + (IxSet.ixGen (Proxy :: Proxy UserId)) + (IxSet.ixFun (\(CommentView c _) -> getTerms c)) + +-- ** NewComment + +-- | A NewComment is the main infos for a Comment +data NewComment = + NewComment + { parent :: ParentId -- ^ UUID + , slug :: Slug -- ^ Text (URL) + , content :: Content -- ^ Text + , userid :: UserId -- ^ UUID + } deriving (Generic,Typeable,Data,Eq,Ord,Show) + +-- Web +instance FromJSON NewComment where parseJSON = genericParseJSON defaultOptions +instance ToJSON NewComment where toJSON = genericToJSON defaultOptions +instance Form.FromForm NewComment where + fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity} + +-- Store / SQLite +instance SOP.Generic NewComment +instance SOP.HasDatatypeInfo NewComment +deriving instance SQLiteSchemas NewComment +instance FromRow NewComment where fromRow = SQL.genericFromRow +instance ToRow NewComment where toRow = SQL.genericToRow + +-- Comments RAM Indexing +type NewCommentIxs = '[ParentId,Slug,Content,UserId,Term] +instance IxSet.Indexable NewCommentIxs Comment where + indices = IxSet.ixList + (IxSet.ixGen (Proxy :: Proxy ParentId)) + (IxSet.ixGen (Proxy :: Proxy Slug)) + (IxSet.ixGen (Proxy :: Proxy Content)) + (IxSet.ixGen (Proxy :: Proxy UserId)) + (IxSet.ixFun getTerms) + +-- *** Field ParentId +newtype ParentId = ParentId (Maybe UUID) deriving (Eq,Ord,Show,Generic,Data) +deriving anyclass instance FromJSON ParentId +deriving anyclass instance ToJSON ParentId +deriving newtype instance ToField ParentId +deriving newtype instance FromField ParentId +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (ParentId ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) + +data DecodeUUIDException = DecodeUUIDException deriving (Show) +instance Ex.Exception DecodeUUIDException +instance ToField UUID where + toField = SQLText . UUID.toText + +-- *** Field Slug +newtype Slug = Slug Text deriving (Eq,Ord,Show,Generic,Data) +instance StringConv Slug [Char] where strConv l (Slug sl) = strConv l sl +instance StringConv Slug Text where strConv l (Slug sl) = strConv l sl +deriving anyclass instance FromJSON Slug +deriving anyclass instance ToJSON Slug +deriving newtype instance ToField Slug +deriving newtype instance FromField Slug +instance FromRow Slug where fromRow = Slug <$> field +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Slug ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) + +-- *** Field UserId +newtype UserId = UserId Text deriving (Eq,Ord,Show,Generic,Data) +instance StringConv UserId [Char] where strConv l (UserId sl) = strConv l sl +instance StringConv UserId Text where strConv l (UserId sl) = strConv l sl +deriving anyclass instance FromJSON UserId +deriving anyclass instance ToJSON UserId +deriving newtype instance FromField UserId +deriving newtype instance ToField UserId +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (UserId ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) + +-- *** Field Content +newtype Content = Content Text deriving (Eq,Ord,Show,Generic,Data) +instance StringConv Content [Char] where strConv l (Content sl) = strConv l sl +instance StringConv Content Text where strConv l (Content sl) = strConv l sl +deriving anyclass instance FromJSON Content +deriving anyclass instance ToJSON Content +deriving newtype instance FromField Content +deriving newtype instance ToField Content +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Content ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) + +newtype Term = Term Text deriving (Eq,Ord,Generic) + +instance FormI.FromHttpApiData ParentId where + parseUrlPiece s = do + txt <- FormI.parseUrlPiece s + if Text.null txt + then return (ParentId Nothing) + else case UUID.fromText txt of + Nothing -> Left $ "Parent ID is not an UUID (" <> txt <> ")" + Just uuid -> return (ParentId (Just uuid)) +instance FormI.FromHttpApiData Slug where parseUrlPiece = fmap Slug . FormI.parseUrlPiece +instance FormI.FromHttpApiData Content where parseUrlPiece = fmap Content . FormI.parseUrlPiece +instance FormI.FromHttpApiData UserId where parseUrlPiece = fmap UserId . FormI.parseUrlPiece + + +getTerms :: Comment -> [Term] +getTerms = fmap Term . Text.split (not . isAlphaNum) . unContent . content . val + where unContent (Content x) = x + +-- * Orphan IxSet ToJSON instance +instance ( Ord a + , ToJSON a + , IxSet.Indexable ixs a + , Typeable a) => ToJSON (IxSet.IxSet ixs a) where + toJSON i = toJSON (IxSet.toList i) diff --git a/src/Aggreact/Comments/Views.hs b/src/Aggreact/Comments/Views.hs new file mode 100644 index 0000000..0e25a01 --- /dev/null +++ b/src/Aggreact/Comments/Views.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# 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 +Description : Example of a library file. +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Main datastructures + +-} +module Aggreact.Comments.Views +where + +-------------------------------------------------------------------------------- +import Protolude hiding (get, put) + +-------------------------------------------------------------------------------- +import Aggreact.Comments.Types +import Aggreact.Html (boilerplate, loginWidget, + urlEncode) +import Aggreact.User (NewUser (..), User) + +-------------------------------------------------------------------------------- +import Data.Aeson (ToJSON (..)) +import Data.Duration (approximativeDuration) +import qualified Data.IxSet.Typed as IxSet +import Data.String (IsString (..)) +import Data.Time (UTCTime, diffUTCTime) +import Data.Time.Clock.Serialize () +import Data.Time.Format () +import qualified Data.UUID as UUID +import Database.Store (DefaultMetas (..), Entity (..)) +import Text.Blaze.Html5 ((!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +{- * Structure + +Each entity should have the following properties: + +* provide a type that represent the internal structure @Struct@ +* provide a type that represent the metas structure @Metas@ +* @Entity Metas Struct@ should be an instance of some Backend Store typeclass +* @Entity Metas Struct@ should be an instance of 'ToJSON' +* @Metas@ should be an instance of 'FromJSON', 'FromForm' and mainly one for all + content-type you like + +-} + +-- * Operations + +data CommentPage = + CommentPage + { commentPageUrl :: Text + , commentPageViewTime :: UTCTime + , commentPageComment :: Comment + , muser :: Maybe User + } +instance ToJSON CommentPage where + toJSON cp = toJSON (commentPageComment cp) + +-- | helper for conversions +cvt :: StringConv a [Char] => a -> H.AttributeValue +cvt = fromString . toS + +extlink :: StringConv a [Char] => a -> Text -> H.Html +extlink url txt = H.a + ! A.href (cvt url) + ! A.target "_blank" + ! A.rel "noopener noreferrer nofollow" + $ do + H.text txt + H.sup $ H.text "⬀" + +instance H.ToMarkup CommentPage where + toMarkup CommentPage{..} = boilerplate (loginWidget muser) $ do + let sl = commentPageComment & val & slug & toS + cid = commentPageUrl + H.h2 $ do + H.a ! A.href ("/comments/" <> cvt (urlEncode (toS sl)) <> "#" <> cvt cid) $ H.text "Comment" + H.text " for " + extlink sl sl + displayComment commentPageComment commentPageViewTime (pure ()) + commentForm sl muser (Just (cvt cid)) + + +data CreatedComment = + CreatedComment + { viewTime :: UTCTime + , comment :: Comment + , muser :: Maybe User + } +instance ToJSON CreatedComment where + toJSON cp = toJSON (comment cp) + +commentLink :: Comment -> H.Html +commentLink c = do + let s = slug (val c) + i = id c + url = toS ("/comments/" <> urlEncode (toS s) <> "#" <> toS i) + H.a ! A.href (fromString url) + $ H.text (toS s) + +instance H.ToMarkup CreatedComment where + toMarkup CreatedComment{..} = + boilerplate (loginWidget muser) $ do + H.h2 $ do + H.text "Comments for " + commentLink comment + displayOneComment comment viewTime + +data CommentsPage = + CommentsPage + { url :: Text + , viewTime :: UTCTime + , comments :: CommentViews + , muser :: Maybe User + } + +instance ToJSON CommentsPage where + toJSON cp = toJSON (comments cp) + +instance H.ToMarkup CommentsPage where + toMarkup CommentsPage{..} = do + let roots = comments IxSet.@= ParentId Nothing + boilerplate (loginWidget muser) $ do + H.h2 $ do + H.text "Comments for " + H.a ! A.href (cvt url) $ H.text url + commentForm url muser Nothing + H.ul $ traverse_ (showChildren comments viewTime) (IxSet.toList roots) + +commentForm :: StringConv a [Char] => a -> Maybe User -> Maybe H.AttributeValue -> H.Html +commentForm _ Nothing _ = H.div (H.i (H.text "Please login to comment.")) +commentForm slug (Just user) mparent = + H.form ! A.action "/comments" ! A.method "post" $ do + H.input ! A.type_ "hidden" ! A.name "userid" ! A.value (cvt (nick (val user))) + H.input ! A.type_ "hidden" ! A.name "parent" ! A.value (fromMaybe "" mparent) + H.input ! A.type_ "hidden" ! A.name "slug" ! A.value (cvt slug) + (H.textarea ! A.name "content" ! A.rows "6" ! A.cols "60" ! A.maxlength "5000") "" + H.br + H.input ! A.type_ "submit" ! A.value "add comment" + +showChildren :: CommentViews -> UTCTime -> CommentView -> H.Markup +showChildren cvs vt cv@(CommentView comment _) = H.li $ + displayCommentView cv vt $ do + let children = cvs IxSet.@= ParentId (Just (toS (id comment))) + if IxSet.null children + then return () + else H.ul $ traverse_ (showChildren cvs vt) (IxSet.toList children) + +displayOneComment :: Comment -> UTCTime -> H.Markup +displayOneComment comment vt = do + let inputid = "toggle-" <> UUID.toString (toS (id comment)) + H.input ! A.type_ "checkbox" ! A.class_ "toggleinput" ! A.id (cvt inputid) + H.div $ do + let cid = UUID.toString (toS (id comment)) + s = slug (val comment) + 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.a H.! A.href (fromString (toS ("/comments/" <> urlEncode (toS s)))) $ H.text (toS s) + H.span ! A.class_ "time" $ do + 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" + +displayCommentView :: CommentView -> UTCTime -> H.Markup -> H.Markup +displayCommentView (CommentView comment user) vt children = do + let inputid = "toggle-" <> UUID.toString (toS (id comment)) + H.input ! A.type_ "checkbox" ! A.class_ "toggleinput" ! A.id (cvt inputid) + H.div $ do + let cid = UUID.toString (toS (id comment)) + 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.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 + +displayComment :: Comment -> UTCTime -> H.Markup -> H.Markup +displayComment comment vt children = do + let inputid = "toggle-" <> UUID.toString (toS (id comment)) + H.input ! A.type_ "checkbox" ! A.class_ "toggleinput" ! A.id (cvt inputid) + H.div $ do + let cid = UUID.toString (toS (id comment)) + 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 diff --git a/src/Aggreact/Html.hs b/src/Aggreact/Html.hs index 866ad3b..20c3f1a 100644 --- a/src/Aggreact/Html.hs +++ b/src/Aggreact/Html.hs @@ -30,6 +30,7 @@ module Aggreact.Html ( boilerplate , urlEncode , loginWidget + , LoginPage(..) ) where @@ -48,13 +49,23 @@ import Database.Store (Entity(..)) container :: H.Html -> H.Html container = H.div ! A.class_ "container" -loginWidget :: Maybe User -> H.Markup -loginWidget Nothing = +loginPage :: H.Html +loginPage = H.form ! A.action "/login" ! A.method "post" $ do + H.label (H.text "username") H.input ! A.name "username" - H.input ! A.name "password" + H.br + H.label (H.text "password") + H.input ! A.type_ "password" ! A.name "password" H.br H.input ! A.type_ "submit" ! A.value "Login" + +data LoginPage = LoginPage +instance H.ToMarkup LoginPage where + toMarkup _ = boilerplate (return ()) loginPage + +loginWidget :: Maybe User -> H.Markup +loginWidget Nothing = H.a ! A.href "/login" $ H.text "Login" loginWidget (Just (Entity _ nu _)) = H.span $ H.text (toS (nick nu)) boilerplate :: H.Markup -> H.Markup -> H.Html diff --git a/src/Service/Config.hs b/src/Service/Config.hs new file mode 100644 index 0000000..687c2ad --- /dev/null +++ b/src/Service/Config.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- Common +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : Database.Store.SQLite +Description : SQLite implentation for Store +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Provide a Service Abstraction + +-} +module Service.Config where + +import Protolude hiding (Handle) + +import Service.Service +import Dhall +import Data.Yaml +import System.FilePath + +data ConfigService a +newtype ConfigServiceConfig = ConfigServiceConfig { configFile :: FilePath } +newtype ConfigSvc a = ConfigSvc { getConfig :: a } + +{- + +Configuration service that can read a configuration from a file. + +-} +instance ( a ~ b + , Interpret b + , FromJSON b + ) => Service (ConfigService a) b where + type Config (ConfigService a) b = ConfigServiceConfig + type Handle (ConfigService a) b = ConfigSvc b + init _ ConfigServiceConfig{..} = ConfigSvc <$> + case takeExtension configFile of + ".dhall" -> input auto (toS configFile) + ".json" -> parseyaml -- json are yaml + ".yaml" -> parseyaml + _ -> die "unrecognized format (only .dhall, .json and .yaml are supported)" + where + parseyaml = do + parseResult <- decodeFileEither configFile + case parseResult of + Left err -> die ("Error while parsing " <> toS configFile <> ":\n" + <> toS (prettyPrintParseException err)) + Right c -> return c diff --git a/src/Service/Service.hs b/src/Service/Service.hs new file mode 100644 index 0000000..b42bb68 --- /dev/null +++ b/src/Service/Service.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- Common +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : Database.Store.SQLite +Description : SQLite implentation for Store +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Provide a Service Abstraction + +-} +module Service.Service where + +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 + init :: Proxy (Service s a) -> Config s a -> IO (Handle s a) + stop :: Proxy (Service s a) -> Handle s a -> IO () + stop _ _ = pure () + withService :: Config s a -> (Handle s a -> IO b) -> IO b + withService config = bracket (init svc config) (stop svc) + where svc = Proxy :: Proxy (Service s a) +