first refacto by concern
This commit is contained in:
parent
1381b35a01
commit
68dd8ec479
9 changed files with 187 additions and 127 deletions
|
@ -2,7 +2,7 @@
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: b25d763a18f7abd2dd41f84f6e8923a72cfbde56ee75daf4de8e5c10a24b3c19
|
||||
-- hash: baf75307a9c628aa3d68c8e108beda42a689496d986f883d8d19ca9e1da2961a
|
||||
|
||||
name: aggreact
|
||||
version: 0.1.0.0
|
||||
|
@ -29,6 +29,7 @@ library
|
|||
exposed-modules:
|
||||
Aggreact
|
||||
Aggreact.Comments
|
||||
Aggreact.Comments.Server
|
||||
Aggreact.Comments.StoreService
|
||||
Aggreact.Comments.Types
|
||||
Aggreact.Comments.Views
|
||||
|
|
2
devel.sh
2
devel.sh
|
@ -1,5 +1,5 @@
|
|||
#!/bin/bash
|
||||
target="aggreact"
|
||||
ghcid \
|
||||
--command "stack ghci $target --ghci-options=-fobject-code" \
|
||||
--command "stack ghci --with-ghc ghci \"--docker-run-args=--interactive=true --tty=false\" $target --no-build --ghci-options=-fobject-code" \
|
||||
--test "DevelMain.update"
|
||||
|
|
|
@ -50,10 +50,7 @@ import Aggreact.User
|
|||
|
||||
import Clay (Css)
|
||||
import Data.Aeson
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import Data.Time (getCurrentTime)
|
||||
import qualified Data.UUID as UUID
|
||||
import Database.Store (Entity(..), Id (..))
|
||||
import Network.Wai (Application)
|
||||
import Servant
|
||||
import Servant.Errors
|
||||
|
@ -87,7 +84,7 @@ instance FromJSON Login
|
|||
instance Form.FromForm Login where
|
||||
fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
|
||||
|
||||
type Unprotected =
|
||||
type Unauthenticated =
|
||||
"login"
|
||||
:> (ReqBody '[JSON, FormUrlEncoded] Login
|
||||
:> PostNoContent '[JSON, FormUrlEncoded]
|
||||
|
@ -96,8 +93,20 @@ type Unprotected =
|
|||
NoContent)
|
||||
:<|> Get '[HTML] LoginPage)
|
||||
|
||||
type API auths = (Servant.Auth.Server.Auth auths User :> CommentAPI)
|
||||
:<|> Unprotected
|
||||
type API auths =
|
||||
Auth auths User :> Authenticated
|
||||
:<|> Unauthenticated
|
||||
|
||||
type Authenticated =
|
||||
HomepageAPI
|
||||
:<|> CommentAPI
|
||||
|
||||
serverAuthenticated :: Settings
|
||||
-> Servant.Auth.Server.AuthResult User
|
||||
-> Server (Authenticated)
|
||||
serverAuthenticated settings@Settings{..} authresult =
|
||||
homepageAPI settings authresult
|
||||
:<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler) authresult
|
||||
|
||||
data Settings =
|
||||
Settings { cookieSettings :: CookieSettings
|
||||
|
@ -107,8 +116,8 @@ data Settings =
|
|||
}
|
||||
|
||||
server :: Settings -> Server (API auths)
|
||||
server settings@Settings{..} =
|
||||
commentAPI settings
|
||||
server settings =
|
||||
serverAuthenticated settings
|
||||
:<|> checkCreds settings
|
||||
:<|> return LoginPage
|
||||
|
||||
|
@ -139,30 +148,20 @@ checkCreds Settings{..} (Login loginNick loginPass) = do
|
|||
|
||||
-- / Auth
|
||||
|
||||
type CommentAPI =
|
||||
"main.css" :> Get '[CSS] Css
|
||||
type HomepageAPI =
|
||||
"main.css" :> Get '[CSS] Css
|
||||
:<|> Get '[HTML] Homepage
|
||||
:<|> "comments" :> Capture "slug" Text
|
||||
:> Get '[HTML,JSON] CommentsPage
|
||||
:<|> "slugs"
|
||||
:> Get '[JSON] [Slug]
|
||||
:<|> "comments" :> ReqBody '[JSON, FormUrlEncoded] NewComment
|
||||
:> PostCreated '[HTML,JSON] CreatedComment
|
||||
:<|> "comment" :> Capture "commentId" Text
|
||||
:> Get '[HTML,JSON] CommentPage
|
||||
|
||||
commentAPI :: Settings -> Servant.Auth.Server.AuthResult User -> Server CommentAPI
|
||||
commentAPI settings@Settings{..} authResult =
|
||||
homepageAPI :: Settings
|
||||
-> Servant.Auth.Server.AuthResult User
|
||||
-> Server HomepageAPI
|
||||
homepageAPI settings@Settings{..} authResult =
|
||||
let muser = case authResult of
|
||||
(Servant.Auth.Server.Authenticated user) -> Just user
|
||||
_ -> Nothing
|
||||
in
|
||||
return genCss
|
||||
:<|> initHomepage muser settings
|
||||
:<|> showComments muser commentHandler
|
||||
:<|> liftIO (getSlugs commentHandler)
|
||||
:<|> postNewComment muser commentHandler
|
||||
:<|> showComment muser commentHandler
|
||||
|
||||
initHomepage :: Maybe User -> Settings -> Handler Homepage
|
||||
initHomepage muser Settings{..} =
|
||||
|
@ -172,41 +171,6 @@ initHomepage muser Settings{..} =
|
|||
<*> getCurrentTime
|
||||
<*> return muser
|
||||
|
||||
showComments :: Maybe User -> CommentHandler -> Text -> Handler CommentsPage
|
||||
showComments muser CommentHandler{..} s = do
|
||||
cvs <- liftIO $ commentsView (Slug s)
|
||||
now <- liftIO getCurrentTime
|
||||
liftIO $ print cvs
|
||||
return CommentsPage { url = s
|
||||
, viewTime = now
|
||||
, comments = IxSet.fromList cvs
|
||||
, muser = muser
|
||||
}
|
||||
|
||||
showComment :: Maybe User -> CommentHandler -> Text -> Handler CommentPage
|
||||
showComment muser CommentHandler{..} i =
|
||||
case UUID.fromText i of
|
||||
Nothing -> notFound ""
|
||||
Just uuid -> do
|
||||
cs <- liftIO . readComment . Id $ uuid
|
||||
now <- liftIO getCurrentTime
|
||||
case cs of
|
||||
Just c -> return CommentPage { commentPageUrl = i
|
||||
, commentPageViewTime = now
|
||||
, commentPageComment = c
|
||||
, muser = muser
|
||||
}
|
||||
_ -> notFound ""
|
||||
|
||||
postNewComment :: Maybe User -> CommentHandler -> NewComment -> Handler CreatedComment
|
||||
postNewComment Nothing _ch _ = unauthorized "You must log in to post new comments"
|
||||
postNewComment muser@(Just (Entity i _ _)) ch nc =
|
||||
CreatedComment <$> liftIO getCurrentTime
|
||||
<*> liftIO (createComment ch (nc { userid = UserId (toS i) }))
|
||||
<*> return muser
|
||||
|
||||
|
||||
|
||||
-- -- * User API
|
||||
--
|
||||
-- type UserAPI =
|
||||
|
|
|
@ -7,30 +7,19 @@ Maintainer : yann.esposito@gmail.com
|
|||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Main datastructures
|
||||
This module is here just to re-export sub modules.
|
||||
Because the original module was split because it was too big.
|
||||
|
||||
-}
|
||||
module Aggreact.Comments
|
||||
(
|
||||
-- * Types
|
||||
Comment
|
||||
, CommentPage (..)
|
||||
, CommentsPage (..)
|
||||
, CreatedComment (..)
|
||||
, NewComment (..)
|
||||
, Comments
|
||||
, Slug (..)
|
||||
, ParentId (..)
|
||||
, UserId (..)
|
||||
-- * Usage for DB
|
||||
, CommentDBConf
|
||||
, newCommentHandler
|
||||
, CommentHandler(..)
|
||||
-- * HTML
|
||||
, displayOneComment
|
||||
) where
|
||||
|
||||
import Aggreact.Comments.StoreService
|
||||
import Aggreact.Comments.Types
|
||||
import Aggreact.Comments.Views
|
||||
( module Aggreact.Comments.StoreService
|
||||
, module Aggreact.Comments.Types
|
||||
, module Aggreact.Comments.Views
|
||||
, module Aggreact.Comments.Server
|
||||
)
|
||||
where
|
||||
|
||||
import Aggreact.Comments.StoreService
|
||||
import Aggreact.Comments.Types
|
||||
import Aggreact.Comments.Views
|
||||
import Aggreact.Comments.Server
|
||||
|
|
112
src/Aggreact/Comments/Server.hs
Normal file
112
src/Aggreact/Comments/Server.hs
Normal file
|
@ -0,0 +1,112 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
-- Local Pragmas
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
-- 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 Routes and Servant Handlers
|
||||
|
||||
-}
|
||||
|
||||
module Aggreact.Comments.Server
|
||||
where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Protolude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Aggreact.Comments.Types
|
||||
import Aggreact.Comments.StoreService (CommentHandler(..))
|
||||
import Aggreact.Comments.Views
|
||||
import Aggreact.User (UserHandler(..),User)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Data.Time (getCurrentTime)
|
||||
import Database.Store (Entity(..), Id (..))
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import Servant
|
||||
import Servant.Errors
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
import Servant.Auth.Server (AuthResult(..))
|
||||
|
||||
type CommentAPI =
|
||||
"comments"
|
||||
:> Capture "slug" Text
|
||||
:> Get '[HTML,JSON] CommentsPage
|
||||
:<|> "slugs"
|
||||
:> Get '[JSON] [Slug]
|
||||
:<|> "comments"
|
||||
:> ReqBody '[JSON, FormUrlEncoded] NewComment
|
||||
:> PostCreated '[HTML,JSON] CreatedComment
|
||||
:<|> "comment" :> Capture "commentId" Text
|
||||
:> Get '[HTML,JSON] CommentPage
|
||||
|
||||
data Handlers =
|
||||
Handlers { userHandler :: UserHandler
|
||||
, commentHandler :: CommentHandler
|
||||
}
|
||||
|
||||
commentAPI :: Handlers -> AuthResult User -> Server CommentAPI
|
||||
commentAPI Handlers{..} authResult =
|
||||
let muser = case authResult of
|
||||
(Authenticated user) -> Just user
|
||||
_ -> Nothing
|
||||
in
|
||||
showComments muser commentHandler
|
||||
:<|> liftIO (getSlugs commentHandler)
|
||||
:<|> postNewComment muser commentHandler
|
||||
:<|> showComment muser commentHandler
|
||||
|
||||
showComments :: Maybe User -> CommentHandler -> Text -> Handler CommentsPage
|
||||
showComments muser CommentHandler{..} s = do
|
||||
cvs <- liftIO $ commentsView (Slug s)
|
||||
now <- liftIO getCurrentTime
|
||||
liftIO $ print cvs
|
||||
return CommentsPage { url = s
|
||||
, viewTime = now
|
||||
, comments = IxSet.fromList cvs
|
||||
, muser = muser
|
||||
}
|
||||
|
||||
showComment :: Maybe User -> CommentHandler -> Text -> Handler CommentPage
|
||||
showComment muser CommentHandler{..} i =
|
||||
case UUID.fromText i of
|
||||
Nothing -> notFound ""
|
||||
Just uuid -> do
|
||||
cs <- liftIO . readComment . Id $ uuid
|
||||
now <- liftIO getCurrentTime
|
||||
case cs of
|
||||
Just c -> return CommentPage { commentPageUrl = i
|
||||
, commentPageViewTime = now
|
||||
, commentPageComment = c
|
||||
, muser = muser
|
||||
}
|
||||
_ -> notFound ""
|
||||
|
||||
postNewComment :: Maybe User -> CommentHandler -> NewComment -> Handler CreatedComment
|
||||
postNewComment Nothing _ch _ = unauthorized "You must log in to post new comments"
|
||||
postNewComment muser@(Just (Entity i _ _)) ch nc =
|
||||
CreatedComment <$> liftIO getCurrentTime
|
||||
<*> liftIO (createComment ch (nc { userid = UserId (toS i) }))
|
||||
<*> return muser
|
|
@ -31,12 +31,7 @@ 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
|
||||
Comment Store Service
|
||||
|
||||
-}
|
||||
|
||||
|
|
|
@ -37,8 +37,8 @@ Maintainer : yann.esposito@gmail.com
|
|||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Comment datastructures with class instances
|
||||
|
||||
Comment datastructures with class instances here to prevent most Orphan
|
||||
instances.
|
||||
|
||||
- A @Comment@ is a NewComment with metas
|
||||
- A @CommentView@ is a comment along its creator infos
|
||||
|
|
|
@ -28,7 +28,10 @@ Maintainer : yann.esposito@gmail.com
|
|||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Main datastructures
|
||||
Comment Views
|
||||
|
||||
- JSON
|
||||
- HTML
|
||||
|
||||
-}
|
||||
module Aggreact.Comments.Views
|
||||
|
@ -40,7 +43,7 @@ import Protolude hiding (get, put)
|
|||
--------------------------------------------------------------------------------
|
||||
import Aggreact.Comments.Types
|
||||
import Aggreact.Html (boilerplate, loginWidget,
|
||||
urlEncode)
|
||||
urlEncode, cvt, extlink)
|
||||
import Aggreact.User (NewUser (..), User)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -57,44 +60,20 @@ 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
|
||||
-- * Single Comment Page
|
||||
|
||||
-- |
|
||||
data CommentPage =
|
||||
CommentPage
|
||||
{ commentPageUrl :: Text
|
||||
, commentPageViewTime :: UTCTime
|
||||
, commentPageComment :: Comment
|
||||
, muser :: Maybe User
|
||||
{ commentPageUrl :: Text -- ^ the comment id for the url
|
||||
, commentPageViewTime :: UTCTime -- ^ the time of watching the comment
|
||||
, commentPageComment :: Comment -- ^ The comment
|
||||
, muser :: Maybe User -- ^ Viewer
|
||||
}
|
||||
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
|
||||
|
@ -107,6 +86,8 @@ instance H.ToMarkup CommentPage where
|
|||
commentForm sl muser (Just (cvt cid))
|
||||
|
||||
|
||||
-- * Created Comment Page
|
||||
|
||||
data CreatedComment =
|
||||
CreatedComment
|
||||
{ viewTime :: UTCTime
|
||||
|
|
|
@ -2,6 +2,7 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
@ -31,20 +32,23 @@ module Aggreact.Html
|
|||
, urlEncode
|
||||
, loginWidget
|
||||
, LoginPage(..)
|
||||
, cvt
|
||||
, extlink
|
||||
)
|
||||
where
|
||||
|
||||
import Protolude
|
||||
|
||||
import qualified Data.Char as Char
|
||||
import Data.String (IsString (..))
|
||||
import Prelude (String)
|
||||
import Text.Blaze.Html5 ((!))
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
import Text.Printf
|
||||
|
||||
import Aggreact.User (User,NewUser(..))
|
||||
import Database.Store (Entity(..))
|
||||
import Aggreact.User (NewUser (..), User)
|
||||
import Database.Store (Entity (..))
|
||||
|
||||
container :: H.Html -> H.Html
|
||||
container = H.div ! A.class_ "container"
|
||||
|
@ -65,7 +69,7 @@ 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 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
|
||||
|
@ -97,3 +101,17 @@ encode c
|
|||
|
||||
urlEncode :: String -> String
|
||||
urlEncode = concatMap encode
|
||||
|
||||
-- | helper for conversions
|
||||
cvt :: StringConv a [Char] => a -> H.AttributeValue
|
||||
cvt = fromString . toS
|
||||
|
||||
-- | external link (protected by best practice security measures)
|
||||
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 "⬀"
|
||||
|
|
Loading…
Reference in a new issue