diff --git a/aggreact.cabal b/aggreact.cabal index 58fbcb5..97ddb44 100644 --- a/aggreact.cabal +++ b/aggreact.cabal @@ -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 diff --git a/devel.sh b/devel.sh index c096ebc..f389db5 100755 --- a/devel.sh +++ b/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" diff --git a/src/Aggreact.hs b/src/Aggreact.hs index 333efcd..5097431 100644 --- a/src/Aggreact.hs +++ b/src/Aggreact.hs @@ -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 = diff --git a/src/Aggreact/Comments.hs b/src/Aggreact/Comments.hs index 16389c3..443266b 100644 --- a/src/Aggreact/Comments.hs +++ b/src/Aggreact/Comments.hs @@ -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 diff --git a/src/Aggreact/Comments/Server.hs b/src/Aggreact/Comments/Server.hs new file mode 100644 index 0000000..e6c6692 --- /dev/null +++ b/src/Aggreact/Comments/Server.hs @@ -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 diff --git a/src/Aggreact/Comments/StoreService.hs b/src/Aggreact/Comments/StoreService.hs index 06370b1..ca856c8 100644 --- a/src/Aggreact/Comments/StoreService.hs +++ b/src/Aggreact/Comments/StoreService.hs @@ -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 -} diff --git a/src/Aggreact/Comments/Types.hs b/src/Aggreact/Comments/Types.hs index 7af5cb9..09c1acf 100644 --- a/src/Aggreact/Comments/Types.hs +++ b/src/Aggreact/Comments/Types.hs @@ -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 diff --git a/src/Aggreact/Comments/Views.hs b/src/Aggreact/Comments/Views.hs index 0e25a01..8836550 100644 --- a/src/Aggreact/Comments/Views.hs +++ b/src/Aggreact/Comments/Views.hs @@ -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 diff --git a/src/Aggreact/Html.hs b/src/Aggreact/Html.hs index 20c3f1a..ed63aa1 100644 --- a/src/Aggreact/Html.hs +++ b/src/Aggreact/Html.hs @@ -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 "⬀"