🚧 WIP 🚧
This commit is contained in:
Yann Esposito (Yogsototh)
parent
ff61112333
commit
1381b35a01
GPG key ID:
7B19A4C650D59646
11 changed files with 797 additions and 497 deletions
|
|
@ -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
|
||||
|
|
|
|||
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" } }
|
||||
32
package.yaml
32
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
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
|
||||
, 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
|
||||
|
|
|
|||
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