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
|
||||
--
|
||||
-- hash: 2f996683b334732c7c907582b5ed809106726926753941072b6a9edab56229c5
|
||||
-- hash: a1ac6adc85594bcb24c0862b8aa2efd0aef6579e4ab183263e137cbdfeef1dfe
|
||||
|
||||
name: aggreact
|
||||
version: 0.1.0.0
|
||||
|
@ -39,6 +39,7 @@ library
|
|||
acid-state
|
||||
, aeson
|
||||
, base >=4.8 && <5
|
||||
, blaze-html
|
||||
, cereal
|
||||
, cereal-text
|
||||
, cereal-time
|
||||
|
@ -47,10 +48,13 @@ library
|
|||
, protolude
|
||||
, safecopy
|
||||
, servant
|
||||
, servant-blaze
|
||||
, servant-server
|
||||
, text
|
||||
, time
|
||||
, uuid
|
||||
, wai
|
||||
, warp
|
||||
default-language: Haskell2010
|
||||
|
||||
executable aggreact
|
||||
|
|
|
@ -29,6 +29,7 @@ library:
|
|||
dependencies:
|
||||
- aeson
|
||||
- acid-state
|
||||
- blaze-html
|
||||
- cereal
|
||||
- cereal-text
|
||||
- cereal-time
|
||||
|
@ -36,10 +37,13 @@ library:
|
|||
- ixset
|
||||
- safecopy
|
||||
- servant
|
||||
- servant-blaze
|
||||
- servant-server
|
||||
- text
|
||||
- time
|
||||
- uuid
|
||||
- wai
|
||||
- warp
|
||||
executables:
|
||||
aggreact:
|
||||
main: Main.hs
|
||||
|
|
|
@ -1,6 +1,8 @@
|
|||
import Protolude
|
||||
|
||||
import Aggreact (inc)
|
||||
import Aggreact (mainServe,Conf(..))
|
||||
import Aggreact (mainServe)
|
||||
|
||||
main :: IO ()
|
||||
main = print (inc 41)
|
||||
main = do
|
||||
mainServe db (Conf 3000)
|
||||
|
|
|
@ -1,6 +1,8 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{- |
|
||||
Module : Aggreact
|
||||
|
@ -25,12 +27,27 @@ import Protolude
|
|||
|
||||
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 =
|
||||
"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 ()
|
||||
mainServe = undefined
|
||||
showComments :: DB Comments -> Text -> Handler Comments
|
||||
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 #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
@ -28,16 +29,23 @@ module Aggreact.Comments
|
|||
Id (..)
|
||||
, Comment (..)
|
||||
, Comments
|
||||
, Slug (..)
|
||||
, ParentId (..)
|
||||
, UserId (..)
|
||||
, DB
|
||||
-- * Operations
|
||||
, initialComments
|
||||
, createNewComment
|
||||
, getCommentsBySlug
|
||||
, getCommentsByParentId
|
||||
) where
|
||||
|
||||
import Protolude hiding (get, put)
|
||||
|
||||
import qualified Control.Exception as Ex
|
||||
import Data.Acid (AcidState, Query, Update,
|
||||
makeAcidic)
|
||||
import qualified Data.Acid as Acid
|
||||
import Data.Acid (Query, Update, makeAcidic, AcidState)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import Data.Char (isAlphaNum)
|
||||
import Data.Data (Data (..))
|
||||
|
@ -51,7 +59,9 @@ import Data.Time.Clock.Serialize ()
|
|||
import Data.Typeable (Typeable)
|
||||
import Data.UUID (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
|
||||
|
||||
|
@ -83,7 +93,7 @@ deriving instance FromJSON Id
|
|||
deriving instance ToJSON 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 ToJSON ParentId
|
||||
deriving instance Serialize ParentId
|
||||
|
@ -102,6 +112,8 @@ newtype Content = Content Text deriving (Eq,Ord,Generic,Data)
|
|||
deriving instance FromJSON Content
|
||||
deriving instance ToJSON 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)
|
||||
|
||||
|
@ -155,15 +167,15 @@ commentById cid = do
|
|||
comments <- ask
|
||||
return (IxSet.getOne (comments IxSet.@= cid))
|
||||
|
||||
commentsByParentId :: ParentId -> Query Comments [Comment]
|
||||
commentsByParentId :: ParentId -> Query Comments Comments
|
||||
commentsByParentId pid = do
|
||||
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
|
||||
comments <- ask
|
||||
return (IxSet.toList (comments IxSet.@= rid))
|
||||
return (comments IxSet.@= rid)
|
||||
|
||||
$(makeAcidic ''Comments [ 'createComment
|
||||
, 'updateComment
|
||||
|
@ -178,8 +190,29 @@ type DB a = AcidState a
|
|||
|
||||
createNewComment :: DB Comments -> ParentId -> Slug -> UserId -> Content -> IO Comment
|
||||
createNewComment db pid s uid txt = do
|
||||
newId <- fmap Id UUID.nextRandom
|
||||
newId <- fmap Id UUIDV4.nextRandom
|
||||
now <- getCurrentTime
|
||||
let newComment = Comment newId pid s now txt uid
|
||||
Acid.update db (UpdateComment 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