🚧 WIP 🚧
This commit is contained in:
parent
ff61112333
commit
1381b35a01
11 changed files with 797 additions and 497 deletions
|
@ -2,7 +2,7 @@
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: ffbf5cf45e9828aaa0ada5427256e10f89a060d93ec2e7d80d807ac2bb72d2b3
|
-- hash: b25d763a18f7abd2dd41f84f6e8923a72cfbde56ee75daf4de8e5c10a24b3c19
|
||||||
|
|
||||||
name: aggreact
|
name: aggreact
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -29,6 +29,9 @@ library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Aggreact
|
Aggreact
|
||||||
Aggreact.Comments
|
Aggreact.Comments
|
||||||
|
Aggreact.Comments.StoreService
|
||||||
|
Aggreact.Comments.Types
|
||||||
|
Aggreact.Comments.Views
|
||||||
Aggreact.Css
|
Aggreact.Css
|
||||||
Aggreact.Homepage
|
Aggreact.Homepage
|
||||||
Aggreact.Html
|
Aggreact.Html
|
||||||
|
@ -41,6 +44,8 @@ library
|
||||||
Generics.SOP.Fieldnames
|
Generics.SOP.Fieldnames
|
||||||
Servant.Clay
|
Servant.Clay
|
||||||
Servant.Errors
|
Servant.Errors
|
||||||
|
Service.Config
|
||||||
|
Service.Service
|
||||||
other-modules:
|
other-modules:
|
||||||
Paths_aggreact
|
Paths_aggreact
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
|
@ -57,6 +62,8 @@ library
|
||||||
, cereal-time
|
, cereal-time
|
||||||
, clay
|
, clay
|
||||||
, containers
|
, containers
|
||||||
|
, dhall
|
||||||
|
, filepath
|
||||||
, foreign-store
|
, foreign-store
|
||||||
, generics-sop
|
, generics-sop
|
||||||
, http-api-data
|
, http-api-data
|
||||||
|
@ -78,6 +85,7 @@ library
|
||||||
, uuid
|
, uuid
|
||||||
, wai
|
, wai
|
||||||
, warp
|
, warp
|
||||||
|
, yaml
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
executable aggreact
|
executable aggreact
|
||||||
|
|
14
dev.dhall
Normal file
14
dev.dhall
Normal file
|
@ -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" } }
|
|
@ -21,9 +21,8 @@ default-extensions:
|
||||||
- DeriveGeneric # deriving ToJSON ...
|
- DeriveGeneric # deriving ToJSON ...
|
||||||
- DerivingStrategies # remove warn about deriving strategies
|
- DerivingStrategies # remove warn about deriving strategies
|
||||||
- StandaloneDeriving # write deriving instance ...
|
- StandaloneDeriving # write deriving instance ...
|
||||||
# need GHC > 8.6
|
|
||||||
- NamedWildCards # can use _type instead of just _
|
- NamedWildCards # can use _type instead of just _
|
||||||
- PartialTypeSignatures
|
- PartialTypeSignatures # write foo :: (_) => a -> Bool
|
||||||
- BlockArguments # blabla do ... instead of blabla $ do ...
|
- BlockArguments # blabla do ... instead of blabla $ do ...
|
||||||
- NumericUnderscores # write 1_000 instead of 1000
|
- NumericUnderscores # write 1_000 instead of 1000
|
||||||
ghc-options:
|
ghc-options:
|
||||||
|
@ -48,6 +47,8 @@ library:
|
||||||
- cereal-time
|
- cereal-time
|
||||||
- clay
|
- clay
|
||||||
- containers
|
- containers
|
||||||
|
- dhall
|
||||||
|
- filepath
|
||||||
- foreign-store
|
- foreign-store
|
||||||
- http-api-data
|
- http-api-data
|
||||||
- http-media
|
- http-media
|
||||||
|
@ -68,6 +69,7 @@ library:
|
||||||
- uuid
|
- uuid
|
||||||
- wai
|
- wai
|
||||||
- warp
|
- warp
|
||||||
|
- yaml
|
||||||
executables:
|
executables:
|
||||||
aggreact:
|
aggreact:
|
||||||
main: Main.hs
|
main: Main.hs
|
||||||
|
|
|
@ -43,6 +43,7 @@ module Aggreact
|
||||||
import Protolude
|
import Protolude
|
||||||
|
|
||||||
import Aggreact.Comments
|
import Aggreact.Comments
|
||||||
|
import Aggreact.Html
|
||||||
import Aggreact.Css (genCss)
|
import Aggreact.Css (genCss)
|
||||||
import Aggreact.Homepage
|
import Aggreact.Homepage
|
||||||
import Aggreact.User
|
import Aggreact.User
|
||||||
|
@ -88,11 +89,12 @@ instance Form.FromForm Login where
|
||||||
|
|
||||||
type Unprotected =
|
type Unprotected =
|
||||||
"login"
|
"login"
|
||||||
:> ReqBody '[JSON, FormUrlEncoded] Login
|
:> (ReqBody '[JSON, FormUrlEncoded] Login
|
||||||
:> PostNoContent '[JSON, FormUrlEncoded]
|
:> PostNoContent '[JSON, FormUrlEncoded]
|
||||||
(Headers '[ Header "Set-Cookie" SetCookie
|
(Headers '[ Header "Set-Cookie" SetCookie
|
||||||
, Header "Set-Cookie" SetCookie]
|
, Header "Set-Cookie" SetCookie]
|
||||||
NoContent)
|
NoContent)
|
||||||
|
:<|> Get '[HTML] LoginPage)
|
||||||
|
|
||||||
type API auths = (Servant.Auth.Server.Auth auths User :> CommentAPI)
|
type API auths = (Servant.Auth.Server.Auth auths User :> CommentAPI)
|
||||||
:<|> Unprotected
|
:<|> Unprotected
|
||||||
|
@ -108,6 +110,7 @@ server :: Settings -> Server (API auths)
|
||||||
server settings@Settings{..} =
|
server settings@Settings{..} =
|
||||||
commentAPI settings
|
commentAPI settings
|
||||||
:<|> checkCreds settings
|
:<|> checkCreds settings
|
||||||
|
:<|> return LoginPage
|
||||||
|
|
||||||
mainServe :: Conf -> IO ()
|
mainServe :: Conf -> IO ()
|
||||||
mainServe conf = do
|
mainServe conf = do
|
||||||
|
@ -120,13 +123,6 @@ checkCreds :: Settings
|
||||||
-> Handler (Headers '[ Header "Set-Cookie" SetCookie
|
-> Handler (Headers '[ Header "Set-Cookie" SetCookie
|
||||||
, Header "Set-Cookie" SetCookie]
|
, Header "Set-Cookie" SetCookie]
|
||||||
NoContent)
|
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
|
checkCreds Settings{..} (Login loginNick loginPass) = do
|
||||||
muser <- liftIO $ checkUserLogin userHandler loginNick loginPass
|
muser <- liftIO $ checkUserLogin userHandler loginNick loginPass
|
||||||
case muser of
|
case muser of
|
||||||
|
|
|
@ -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
|
Module : Aggreact.Comments
|
||||||
Description : Example of a library file.
|
Description : Example of a library file.
|
||||||
|
@ -58,442 +30,7 @@ module Aggreact.Comments
|
||||||
, displayOneComment
|
, displayOneComment
|
||||||
) where
|
) 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
|
|
||||||
}
|
|
||||||
|
|
154
src/Aggreact/Comments/StoreService.hs
Normal file
154
src/Aggreact/Comments/StoreService.hs
Normal file
|
@ -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
|
||||||
|
}
|
228
src/Aggreact/Comments/Types.hs
Normal file
228
src/Aggreact/Comments/Types.hs
Normal file
|
@ -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)
|
228
src/Aggreact/Comments/Views.hs
Normal file
228
src/Aggreact/Comments/Views.hs
Normal file
|
@ -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
|
|
@ -30,6 +30,7 @@ module Aggreact.Html
|
||||||
( boilerplate
|
( boilerplate
|
||||||
, urlEncode
|
, urlEncode
|
||||||
, loginWidget
|
, loginWidget
|
||||||
|
, LoginPage(..)
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -48,13 +49,23 @@ import Database.Store (Entity(..))
|
||||||
container :: H.Html -> H.Html
|
container :: H.Html -> H.Html
|
||||||
container = H.div ! A.class_ "container"
|
container = H.div ! A.class_ "container"
|
||||||
|
|
||||||
loginWidget :: Maybe User -> H.Markup
|
loginPage :: H.Html
|
||||||
loginWidget Nothing =
|
loginPage =
|
||||||
H.form ! A.action "/login" ! A.method "post" $ do
|
H.form ! A.action "/login" ! A.method "post" $ do
|
||||||
|
H.label (H.text "username")
|
||||||
H.input ! A.name "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.br
|
||||||
H.input ! A.type_ "submit" ! A.value "Login"
|
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))
|
loginWidget (Just (Entity _ nu _)) = H.span $ H.text (toS (nick nu))
|
||||||
|
|
||||||
boilerplate :: H.Markup -> H.Markup -> H.Html
|
boilerplate :: H.Markup -> H.Markup -> H.Html
|
||||||
|
|
77
src/Service/Config.hs
Normal file
77
src/Service/Config.hs
Normal file
|
@ -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
|
45
src/Service/Service.hs
Normal file
45
src/Service/Service.hs
Normal file
|
@ -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)
|
||||||
|
|
Loading…
Reference in a new issue