first refacto by concern

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

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"

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)
+type API auths =
-                 :<|> Unprotected
+  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{..} =
+server settings =
-  commentAPI 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
+homepageAPI :: Settings
-commentAPI settings@Settings{..} authResult =
+            -> 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 =

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
-  (
+  ( module Aggreact.Comments.StoreService
-    -- * Types
+  , module Aggreact.Comments.Types
-    Comment
+  , module Aggreact.Comments.Views
-  , CommentPage (..)
+  , module Aggreact.Comments.Server
-  , CommentsPage (..)
+  )
-  , CreatedComment (..)
+where
-  , 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
-
+import Aggreact.Comments.Server

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

src/Aggreact/Comments/StoreService.hs

@@ -31,12 +31,7 @@ Maintainer  : yann.esposito@gmail.com
 Stability   : experimental
 Portability : POSIX
 
-Comment datastructures with class instances
+Comment Store Service
-
-
-- 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
 
 -}
 

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

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:
+-- * Single Comment Page
-
-* 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
+  { commentPageUrl      :: Text       -- ^ the comment id for the url
-  , commentPageViewTime :: UTCTime
+  , commentPageViewTime :: UTCTime    -- ^ the time of watching the comment
-  , commentPageComment  :: Comment
+  , commentPageComment  :: Comment    -- ^ The comment
-  , muser               :: Maybe User
+  , 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

src/Aggreact/Html.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE ExplicitForAll             #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedWildCards             #-}
 {-# LANGUAGE NoImplicitPrelude          #-}
@@ -31,19 +32,22 @@ 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           Aggreact.User               (NewUser (..), User)
 import           Database.Store              (Entity (..))
 
 container :: H.Html -> 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 "⬀"