Toward an executable
This commit is contained in:
parent
0e9b889eb1
commit
9784c76702
5 changed files with 80 additions and 20 deletions
|
@ -2,7 +2,7 @@
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 2f996683b334732c7c907582b5ed809106726926753941072b6a9edab56229c5
|
-- hash: a1ac6adc85594bcb24c0862b8aa2efd0aef6579e4ab183263e137cbdfeef1dfe
|
||||||
|
|
||||||
name: aggreact
|
name: aggreact
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -39,6 +39,7 @@ library
|
||||||
acid-state
|
acid-state
|
||||||
, aeson
|
, aeson
|
||||||
, base >=4.8 && <5
|
, base >=4.8 && <5
|
||||||
|
, blaze-html
|
||||||
, cereal
|
, cereal
|
||||||
, cereal-text
|
, cereal-text
|
||||||
, cereal-time
|
, cereal-time
|
||||||
|
@ -47,10 +48,13 @@ library
|
||||||
, protolude
|
, protolude
|
||||||
, safecopy
|
, safecopy
|
||||||
, servant
|
, servant
|
||||||
|
, servant-blaze
|
||||||
, servant-server
|
, servant-server
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, uuid
|
, uuid
|
||||||
|
, wai
|
||||||
|
, warp
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
executable aggreact
|
executable aggreact
|
||||||
|
|
|
@ -29,6 +29,7 @@ library:
|
||||||
dependencies:
|
dependencies:
|
||||||
- aeson
|
- aeson
|
||||||
- acid-state
|
- acid-state
|
||||||
|
- blaze-html
|
||||||
- cereal
|
- cereal
|
||||||
- cereal-text
|
- cereal-text
|
||||||
- cereal-time
|
- cereal-time
|
||||||
|
@ -36,10 +37,13 @@ library:
|
||||||
- ixset
|
- ixset
|
||||||
- safecopy
|
- safecopy
|
||||||
- servant
|
- servant
|
||||||
|
- servant-blaze
|
||||||
- servant-server
|
- servant-server
|
||||||
- text
|
- text
|
||||||
- time
|
- time
|
||||||
- uuid
|
- uuid
|
||||||
|
- wai
|
||||||
|
- warp
|
||||||
executables:
|
executables:
|
||||||
aggreact:
|
aggreact:
|
||||||
main: Main.hs
|
main: Main.hs
|
||||||
|
|
|
@ -1,6 +1,8 @@
|
||||||
import Protolude
|
import Protolude
|
||||||
|
|
||||||
import Aggreact (inc)
|
import Aggreact (mainServe,Conf(..))
|
||||||
|
import Aggreact (mainServe)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = print (inc 41)
|
main = do
|
||||||
|
mainServe db (Conf 3000)
|
||||||
|
|
|
@ -1,6 +1,8 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE Strict #-}
|
{-# LANGUAGE Strict #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
|
|
||||||
{- |
|
{- |
|
||||||
Module : Aggreact
|
Module : Aggreact
|
||||||
|
@ -25,12 +27,27 @@ import Protolude
|
||||||
|
|
||||||
import Aggreact.Comments
|
import Aggreact.Comments
|
||||||
|
|
||||||
import Servant.API
|
import Network.Wai (Application)
|
||||||
|
import qualified Network.Wai.Handler.Warp as Warp
|
||||||
|
import Servant
|
||||||
|
import Servant.HTML.Blaze
|
||||||
|
|
||||||
type CommentAPI =
|
type CommentAPI =
|
||||||
"comments" :> Capture "stub" Text :> Get '[JSON] Comments
|
"comments" :> Capture "slug" Text :> Get '[HTML] Comments
|
||||||
|
|
||||||
data Conf = Conf { port :: Int16 }
|
data Conf = Conf { port :: Int }
|
||||||
|
|
||||||
mainServe :: Conf -> IO ()
|
showComments :: DB Comments -> Text -> Handler Comments
|
||||||
mainServe = undefined
|
showComments db = liftIO . getCommentsBySlug db . Slug
|
||||||
|
|
||||||
|
api :: Proxy CommentAPI
|
||||||
|
api = Proxy
|
||||||
|
|
||||||
|
server :: DB Comments -> Server CommentAPI
|
||||||
|
server db = showComments db
|
||||||
|
|
||||||
|
app :: DB Comments -> Application
|
||||||
|
app db = serve api (server db)
|
||||||
|
|
||||||
|
mainServe :: DB Comments -> Conf -> IO ()
|
||||||
|
mainServe db conf = Warp.run (port conf) (app db)
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
@ -28,16 +29,23 @@ module Aggreact.Comments
|
||||||
Id (..)
|
Id (..)
|
||||||
, Comment (..)
|
, Comment (..)
|
||||||
, Comments
|
, Comments
|
||||||
|
, Slug (..)
|
||||||
|
, ParentId (..)
|
||||||
|
, UserId (..)
|
||||||
|
, DB
|
||||||
-- * Operations
|
-- * Operations
|
||||||
, initialComments
|
, initialComments
|
||||||
, createNewComment
|
, createNewComment
|
||||||
|
, getCommentsBySlug
|
||||||
|
, getCommentsByParentId
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Protolude hiding (get, put)
|
import Protolude hiding (get, put)
|
||||||
|
|
||||||
import qualified Control.Exception as Ex
|
import qualified Control.Exception as Ex
|
||||||
|
import Data.Acid (AcidState, Query, Update,
|
||||||
|
makeAcidic)
|
||||||
import qualified Data.Acid as Acid
|
import qualified Data.Acid as Acid
|
||||||
import Data.Acid (Query, Update, makeAcidic, AcidState)
|
|
||||||
import Data.Aeson (FromJSON, ToJSON)
|
import Data.Aeson (FromJSON, ToJSON)
|
||||||
import Data.Char (isAlphaNum)
|
import Data.Char (isAlphaNum)
|
||||||
import Data.Data (Data (..))
|
import Data.Data (Data (..))
|
||||||
|
@ -51,7 +59,9 @@ import Data.Time.Clock.Serialize ()
|
||||||
import Data.Typeable (Typeable)
|
import Data.Typeable (Typeable)
|
||||||
import Data.UUID (UUID)
|
import Data.UUID (UUID)
|
||||||
import qualified Data.UUID as UUID
|
import qualified Data.UUID as UUID
|
||||||
import qualified Data.UUID.V4 as UUID
|
import qualified Data.UUID.V4 as UUIDV4
|
||||||
|
|
||||||
|
import qualified Text.Blaze.Html5 as H
|
||||||
|
|
||||||
-- * Comments
|
-- * Comments
|
||||||
|
|
||||||
|
@ -83,7 +93,7 @@ deriving instance FromJSON Id
|
||||||
deriving instance ToJSON Id
|
deriving instance ToJSON Id
|
||||||
deriving instance Serialize Id
|
deriving instance Serialize Id
|
||||||
|
|
||||||
newtype ParentId = ParentId UUID deriving (Eq,Ord,Generic,Data)
|
newtype ParentId = ParentId (Maybe UUID) deriving (Eq,Ord,Generic,Data)
|
||||||
deriving instance FromJSON ParentId
|
deriving instance FromJSON ParentId
|
||||||
deriving instance ToJSON ParentId
|
deriving instance ToJSON ParentId
|
||||||
deriving instance Serialize ParentId
|
deriving instance Serialize ParentId
|
||||||
|
@ -102,6 +112,8 @@ newtype Content = Content Text deriving (Eq,Ord,Generic,Data)
|
||||||
deriving instance FromJSON Content
|
deriving instance FromJSON Content
|
||||||
deriving instance ToJSON Content
|
deriving instance ToJSON Content
|
||||||
deriving instance Serialize Content
|
deriving instance Serialize Content
|
||||||
|
instance StringConv Content Text where
|
||||||
|
strConv l (Content t) = strConv l t
|
||||||
|
|
||||||
newtype Term = Term Text deriving (Eq,Ord,Generic)
|
newtype Term = Term Text deriving (Eq,Ord,Generic)
|
||||||
|
|
||||||
|
@ -155,15 +167,15 @@ commentById cid = do
|
||||||
comments <- ask
|
comments <- ask
|
||||||
return (IxSet.getOne (comments IxSet.@= cid))
|
return (IxSet.getOne (comments IxSet.@= cid))
|
||||||
|
|
||||||
commentsByParentId :: ParentId -> Query Comments [Comment]
|
commentsByParentId :: ParentId -> Query Comments Comments
|
||||||
commentsByParentId pid = do
|
commentsByParentId pid = do
|
||||||
comments <- ask
|
comments <- ask
|
||||||
return (IxSet.toList (comments IxSet.@= pid))
|
return (comments IxSet.@= pid)
|
||||||
|
|
||||||
commentsBySlug :: Slug -> Query Comments [Comment]
|
commentsBySlug :: Slug -> Query Comments Comments
|
||||||
commentsBySlug rid = do
|
commentsBySlug rid = do
|
||||||
comments <- ask
|
comments <- ask
|
||||||
return (IxSet.toList (comments IxSet.@= rid))
|
return (comments IxSet.@= rid)
|
||||||
|
|
||||||
$(makeAcidic ''Comments [ 'createComment
|
$(makeAcidic ''Comments [ 'createComment
|
||||||
, 'updateComment
|
, 'updateComment
|
||||||
|
@ -178,8 +190,29 @@ type DB a = AcidState a
|
||||||
|
|
||||||
createNewComment :: DB Comments -> ParentId -> Slug -> UserId -> Content -> IO Comment
|
createNewComment :: DB Comments -> ParentId -> Slug -> UserId -> Content -> IO Comment
|
||||||
createNewComment db pid s uid txt = do
|
createNewComment db pid s uid txt = do
|
||||||
newId <- fmap Id UUID.nextRandom
|
newId <- fmap Id UUIDV4.nextRandom
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
let newComment = Comment newId pid s now txt uid
|
let newComment = Comment newId pid s now txt uid
|
||||||
Acid.update db (UpdateComment newComment)
|
Acid.update db (UpdateComment newComment)
|
||||||
return newComment
|
return newComment
|
||||||
|
|
||||||
|
getCommentsBySlug :: DB Comments -> Slug -> IO Comments
|
||||||
|
getCommentsBySlug db s = Acid.query db (CommentsBySlug s)
|
||||||
|
|
||||||
|
getCommentsByParentId :: DB Comments -> ParentId -> IO Comments
|
||||||
|
getCommentsByParentId db s = Acid.query db (CommentsByParentId s)
|
||||||
|
|
||||||
|
instance H.ToMarkup Comments where
|
||||||
|
toMarkup comments = do
|
||||||
|
let roots = comments IxSet.@= ParentId Nothing
|
||||||
|
H.ul $ traverse_ (showChildren comments) (IxSet.toList roots)
|
||||||
|
where
|
||||||
|
-- showChildren :: Comments -> Comment -> _
|
||||||
|
showChildren cs comment =
|
||||||
|
H.li $ do
|
||||||
|
H.div (H.text (toS (content comment)))
|
||||||
|
let children = cs IxSet.@= id comment
|
||||||
|
if IxSet.null children
|
||||||
|
then return ()
|
||||||
|
else H.ul $ traverse_ (showChildren cs) (IxSet.toList children)
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue