yogsototh/aggreact
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

first refacto by concern

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-01-20 13:34:12 +01:00
parent 1381b35a01
commit 68dd8ec479
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
9 changed files with 187 additions and 127 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
aggreact.cabal
View file

@ -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
View file

@ -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"

80
src/Aggreact.hs
View file

@ -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 =
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 =

29
src/Aggreact/Comments.hs
View file

@ -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
( 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
View 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

7
src/Aggreact/Comments/StoreService.hs
View file

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

4
src/Aggreact/Comments/Types.hs
View file

@ -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

45
src/Aggreact/Comments/Views.hs
View file

@ -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

22
src/Aggreact/Html.hs
View file

@ -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"
@ -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 "⬀"