wip
This commit is contained in:
Yann Esposito (Yogsototh)
parent
ec5c9ca591
commit
fdc99d432b
GPG key ID:
7B19A4C650D59646
5 changed files with 310 additions and 38 deletions
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 1163db1a07517ee5befaea65db6a11d03a31e0d35b88dd576c76cf3c9506866c
|
||||
-- hash: 30f126ffbddf3a9a0ea62f05f8a4b9f3b92fe9389e35647b298afcf322175739
|
||||
|
||||
name: aggreact
|
||||
version: 0.1.0.0
|
||||
|
|
@ -40,7 +40,13 @@ library
|
|||
Aggreact.Homepage
|
||||
Aggreact.Html
|
||||
Aggreact.Scopes
|
||||
Aggreact.Slugs
|
||||
Aggreact.Slugs.Server
|
||||
Aggreact.Slugs.StoreService
|
||||
Aggreact.Slugs.Types
|
||||
Aggreact.Slugs.Views
|
||||
Aggreact.User
|
||||
Data.IxSet.OrphanInstances
|
||||
Database.Store
|
||||
Database.Store.Backend.SQLite
|
||||
Database.Store.CRUD
|
||||
|
|
|
|||
|
|
@ -35,24 +35,23 @@ where
|
|||
import Protolude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Aggreact.Authorization (Access (..),
|
||||
AuthorizationHandler (..))
|
||||
import Aggreact.Slugs.StoreService (CommentHandler (..))
|
||||
import Aggreact.Authorization (Access (..),
|
||||
AuthorizationHandler (..))
|
||||
import Aggreact.Scopes (Scope (..))
|
||||
import Aggreact.Slugs.StoreService (SlugHandler (..))
|
||||
import Aggreact.Slugs.Types
|
||||
import Aggreact.Slugs.Views
|
||||
import Aggreact.Scopes (Scope (..))
|
||||
import Aggreact.User (User, UserHandler (..))
|
||||
import Aggreact.User (User, UserHandler (..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import Data.Time (getCurrentTime)
|
||||
import qualified Data.UUID as UUID
|
||||
import Database.Store (Entity (..), Id (..),
|
||||
minimalId)
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import Data.Time (getCurrentTime)
|
||||
import qualified Data.UUID as UUID
|
||||
import Database.Store (Entity (..), Id (..), minimalId)
|
||||
import Servant
|
||||
import Servant.Auth.Server (AuthResult (..))
|
||||
import Servant.Auth.Server (AuthResult (..))
|
||||
import Servant.Errors
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
|
||||
type SlutAPI =
|
||||
"slugs" :> Get '[JSON] [Slug]
|
||||
|
|
@ -69,7 +68,7 @@ data Handlers =
|
|||
, authorizationHandler :: AuthorizationHandler
|
||||
}
|
||||
|
||||
slugAPI :: Handlers -> AuthResult User -> Server CommentAPI
|
||||
slugAPI :: Handlers -> AuthResult User -> Server SlugAPI
|
||||
slugAPI Handlers{..} authResult =
|
||||
let muser = case authResult of
|
||||
(Authenticated user) -> Just user
|
||||
|
|
@ -79,8 +78,8 @@ slugAPI Handlers{..} authResult =
|
|||
:<|> showSlug muser authorizationHandler slugHandler
|
||||
:<|> postNewSlug muser authorizationHandler slugHandler
|
||||
|
||||
showSlugs :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler SlugsPage
|
||||
showSlugs muser AuthorizationHandler{..} CommentHandler{..} s = do
|
||||
showSlug :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler SlugsPage
|
||||
showSlug muser AuthorizationHandler{..} CommentHandler{..} s = do
|
||||
_ <- filterAccess (Scope "slug" Read) muser
|
||||
cvs <- liftIO $ commentsView (Slug s)
|
||||
now <- liftIO getCurrentTime
|
||||
|
|
@ -91,11 +90,11 @@ showSlugs muser AuthorizationHandler{..} CommentHandler{..} s = do
|
|||
, canComment = hasScope (Scope "comment" Read) muser
|
||||
}
|
||||
|
||||
showSlug :: Maybe User
|
||||
showSlugs :: Maybe User
|
||||
-> AuthorizationHandler
|
||||
-> CommentHandler
|
||||
-> Handler [Slug]
|
||||
showSlug muser AuthorizationHandler{..} ch = do
|
||||
showSlugs muser AuthorizationHandler{..} ch = do
|
||||
_ <- filterAccess (Scope "comment" Read) muser
|
||||
liftIO (getSlugs ch)
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,120 @@
|
|||
-- Local Pragmas
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
-- Common Pragmas (already stated in cabal file but repeated here for some tools)
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{- |
|
||||
Module : Aggreact.Slugs.StoreService
|
||||
Description : SlugStore service
|
||||
Copyright : (c) 2018, Yann Esposito
|
||||
License : ISC
|
||||
Maintainer : yann.esposito@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Slug Store Service
|
||||
|
||||
-}
|
||||
|
||||
module Aggreact.Slugs.StoreService
|
||||
where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Protolude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Aggreact.Slugs.Types
|
||||
import qualified Aggreact.User as User
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Data.Time.Clock.Serialize ()
|
||||
import Data.Time.Format ()
|
||||
import Database.SQLite.Simple (Only (..), query, query_)
|
||||
|
||||
import Database.Store (DefaultMetas (..), Id (..),
|
||||
Store (..))
|
||||
|
||||
|
||||
import Database.Store.Backend.SQLite as SQL
|
||||
import qualified Database.Store.CRUD as CRUD
|
||||
import qualified Database.Store.Search as Search
|
||||
|
||||
|
||||
type SlugSQLiteStore = SQLiteStore IO DefaultMetas NewSlug
|
||||
type DBStore = StartedStore SlugSQLiteStore
|
||||
type SlugDBConf = DBConf SlugSQLiteStore
|
||||
type SlugSearchQuery = Search.SearchQuery SlugSQLiteStore
|
||||
type SlugSearchResult = Search.SearchResult SlugSQLiteStore
|
||||
|
||||
initDBSlugs :: SlugDBConf -> IO DBStore
|
||||
initDBSlugs = init
|
||||
|
||||
stopDBSlugs' :: DBStore -> IO ()
|
||||
stopDBSlugs' = stop
|
||||
|
||||
createSlug' :: DBStore -> NewSlug -> IO Slug
|
||||
createSlug' = CRUD.create
|
||||
|
||||
readSlug' :: DBStore -> Id -> IO (Maybe Slug)
|
||||
readSlug' = CRUD.read
|
||||
|
||||
updateSlug' :: DBStore -> Id -> NewSlug -> IO (Maybe Slug)
|
||||
updateSlug' = CRUD.update
|
||||
|
||||
deleteSlug' :: DBStore -> Id -> IO Bool
|
||||
deleteSlug' = CRUD.delete
|
||||
|
||||
searchSlugs' :: DBStore -> SlugSearchQuery -> IO SlugSearchResult
|
||||
searchSlugs' = Search.search
|
||||
|
||||
-- ** Specific queries
|
||||
|
||||
getSlugs' :: DBStore -> IO [Slug]
|
||||
getSlugs' SQLiteState{..} = liftIO . query_ conn . conv $
|
||||
"SELECT * FROM " <> stTablename <> " ORDER BY created DESC LIMIT 100"
|
||||
|
||||
-- | A slug handler, handle all impure operations needed to Slugs
|
||||
data SlugHandler =
|
||||
SlugHandler
|
||||
{ createSlug :: NewSlug -> IO Slug
|
||||
, readSlug :: Id -> IO (Maybe Slug)
|
||||
, updateSlug :: Id -> NewSlug -> IO (Maybe Slug)
|
||||
, deleteSlug :: Id -> IO Bool
|
||||
, searchSlugs :: SlugSearchQuery -> IO SlugSearchResult
|
||||
, stopDBSlugs :: IO ()
|
||||
, getSlugs :: IO [Slug]
|
||||
}
|
||||
|
||||
-- | Init a new slug handler
|
||||
newSlugHandler :: User.DBStore
|
||||
-> SlugDBConf
|
||||
-> IO SlugHandler
|
||||
newSlugHandler userStore conf = do
|
||||
dbstore <- initDBSlugs conf
|
||||
pure SlugHandler { createSlug = createSlug' dbstore
|
||||
, readSlug = readSlug' dbstore
|
||||
, updateSlug = updateSlug' dbstore
|
||||
, deleteSlug = deleteSlug' dbstore
|
||||
, searchSlugs = searchSlugs' dbstore
|
||||
, stopDBSlugs = stopDBSlugs' dbstore
|
||||
, getSlugs = getSlugs' dbstore
|
||||
}
|
||||
|
|
@ -29,7 +29,7 @@
|
|||
{-# LANGUAGE StandaloneDeriving #-} -- write deriving instance ...
|
||||
{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y)
|
||||
{- |
|
||||
Module : Aggreact.Slugs.StoreService
|
||||
Module : Aggreact.Slugs.Types
|
||||
Description : CommentStore service
|
||||
Copyright : (c) 2018, Yann Esposito
|
||||
License : ISC
|
||||
|
|
@ -46,13 +46,13 @@ instances.
|
|||
|
||||
-}
|
||||
|
||||
module Aggreact.Comments.Types
|
||||
module Aggreact.Slugs.Types
|
||||
where
|
||||
|
||||
|
||||
import Protolude
|
||||
|
||||
import Aggreact.User (User)
|
||||
import Aggreact.User (User,UserId)
|
||||
|
||||
import qualified Control.Exception as Ex
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..),
|
||||
|
|
@ -87,11 +87,11 @@ type Slug = Entity DefaultMetas NewSlug
|
|||
|
||||
-- Slug Indexing
|
||||
type Slugs = IxSet.IxSet SlugIxs Slug
|
||||
type SlugIxs = '[Id,Slug,UserId]
|
||||
type SlugIxs = '[Id,PostURL,UserId]
|
||||
instance IxSet.Indexable SlugIxs Slug where
|
||||
indices = IxSet.ixList
|
||||
(IxSet.ixGen (Proxy :: Proxy Id))
|
||||
(IxSet.ixGen (Proxy :: Proxy Slug))
|
||||
(IxSet.ixGen (Proxy :: Proxy PostURL))
|
||||
(IxSet.ixGen (Proxy :: Proxy UserId))
|
||||
|
||||
-- ** SlugView
|
||||
|
|
@ -106,11 +106,11 @@ deriving instance ToJSON SlugView
|
|||
instance FromRow SlugView where fromRow = SlugView <$> fromRow <*> fromRow
|
||||
-- Indexing
|
||||
type SlugViews = IxSet.IxSet SlugViewIxs SlugView
|
||||
type SlugViewIxs = '[Id,Slug,UserId]
|
||||
type SlugViewIxs = '[Id,PostURL,UserId]
|
||||
instance IxSet.Indexable SlugViewIxs SlugView where
|
||||
indices = IxSet.ixList
|
||||
(IxSet.ixFun (\(SlugView s _) -> [id s]))
|
||||
(IxSet.ixGen (Proxy :: Proxy Slug))
|
||||
(IxSet.ixGen (Proxy :: Proxy PostURL))
|
||||
(IxSet.ixGen (Proxy :: Proxy UserId))
|
||||
|
||||
-- ** NewSlug
|
||||
|
|
@ -118,8 +118,8 @@ instance IxSet.Indexable SlugViewIxs SlugView where
|
|||
-- | A NewSlug is the main infos for a Slug
|
||||
data NewSlug =
|
||||
NewSlug
|
||||
{ slug :: Slug -- ^ Text (URL)
|
||||
, userid :: UserId -- ^ UUID
|
||||
{ slugUrl :: PostURL -- ^ Text (URL)
|
||||
, userid :: UserId -- ^ UUID
|
||||
} deriving (Generic,Typeable,Data,Eq,Ord,Show)
|
||||
|
||||
-- Web
|
||||
|
|
@ -143,15 +143,15 @@ instance IxSet.Indexable NewSlugIxs Slug where
|
|||
(IxSet.ixGen (Proxy :: Proxy UserId))
|
||||
|
||||
-- *** Field Slug
|
||||
newtype Slug = Slug Text deriving (Eq,Ord,Show,Generic,Data)
|
||||
instance StringConv Slug [Char] where strConv l (Slug sl) = strConv l sl
|
||||
instance StringConv Slug Text where strConv l (Slug sl) = strConv l sl
|
||||
deriving anyclass instance FromJSON Slug
|
||||
deriving anyclass instance ToJSON Slug
|
||||
deriving newtype instance ToField Slug
|
||||
deriving newtype instance FromField Slug
|
||||
instance FromRow Slug where fromRow = Slug <$> field
|
||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Slug ': rest) where
|
||||
newtype PostURL = PostURL Text deriving (Eq,Ord,Show,Generic,Data)
|
||||
instance StringConv PostURL [Char] where strConv l (PostURL sl) = strConv l sl
|
||||
instance StringConv PostURL Text where strConv l (PostURL sl) = strConv l sl
|
||||
deriving anyclass instance FromJSON PostURL
|
||||
deriving anyclass instance ToJSON PostURL
|
||||
deriving newtype instance ToField PostURL
|
||||
deriving newtype instance FromField PostURL
|
||||
instance FromRow PostURL where fromRow = PostURL <$> field
|
||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (PostURL ': rest) where
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
|
||||
instance FormI.FromHttpApiData Slug where parseUrlPiece = fmap Slug . FormI.parseUrlPiece
|
||||
instance FormI.FromHttpApiData PostURL where
|
||||
parseUrlPiece = fmap PostURL . FormI.parseUrlPiece
|
||||
|
|
|
|||
|
|
@ -0,0 +1,147 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{- |
|
||||
Module : Aggreact.Slugs
|
||||
Description : Example of a library file.
|
||||
Copyright : (c) 2018, Yann Esposito
|
||||
License : ISC
|
||||
Maintainer : yann.esposito@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Slug Views
|
||||
|
||||
- JSON
|
||||
- HTML
|
||||
|
||||
-}
|
||||
module Aggreact.Slugs.Views
|
||||
where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Protolude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Aggreact.Slugs.Types
|
||||
import Aggreact.Html (boilerplate, cvt, extlink,
|
||||
urlEncode)
|
||||
import Aggreact.User (NewUser (..), User, loginWidget)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Data.Aeson (ToJSON (..))
|
||||
import Data.Duration (approximativeDuration)
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import Data.String (IsString (..))
|
||||
import Data.Time (UTCTime, diffUTCTime)
|
||||
import Data.Time.Clock.Serialize ()
|
||||
import Data.Time.Format ()
|
||||
import qualified Data.UUID as UUID
|
||||
import Database.Store (DefaultMetas (..), Entity (..))
|
||||
import Text.Blaze.Html5 ((!))
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
|
||||
|
||||
-- * Single Slug Page
|
||||
|
||||
-- |
|
||||
data SlugPage =
|
||||
SlugPage
|
||||
{ slug :: Slug -- ^ the comment id for the url
|
||||
, slugPageViewTime :: UTCTime -- ^ the time of watching the comment
|
||||
, muser :: Maybe User -- ^ Viewer
|
||||
, canCreateSlug :: Bool -- ^ true if the user is authorized to comment
|
||||
}
|
||||
instance ToJSON SlugPage where
|
||||
toJSON sp = toJSON (slug sp)
|
||||
|
||||
instance H.ToMarkup SlugPage where
|
||||
toMarkup SlugPage{..} = boilerplate (loginWidget muser) $ do
|
||||
let sl = slug & val & slugUrl & toS
|
||||
H.h2 $ do
|
||||
H.a ! A.href ("/comments/" <> cvt (urlEncode (toS sl))) $ H.text "Slug"
|
||||
H.text " for "
|
||||
extlink sl sl
|
||||
-- displaySlug slug slugPageViewTime (pure ())
|
||||
slugForm canCreateSlug sl (fmap (toS. nick . val) muser)
|
||||
|
||||
slugForm :: StringConv a [Char]
|
||||
=> Bool
|
||||
-> a
|
||||
-> Maybe Text
|
||||
-> H.Html
|
||||
slugForm False _ _ = H.div (H.i (H.text "You can't create a new slug"))
|
||||
slugForm True slUrl Nothing = slugForm True slUrl (Just "anonymous coward")
|
||||
slugForm True slUrl (Just userNick) =
|
||||
H.form ! A.action "/slugs" ! A.method "post" $ do
|
||||
H.input ! A.type_ "hidden" ! A.name "userid" ! A.value (cvt userNick)
|
||||
H.input ! A.type_ "hidden" ! A.name "slugUrl" ! A.value (cvt slUrl)
|
||||
H.br
|
||||
H.input ! A.type_ "submit" ! A.value "add slug"
|
||||
|
||||
-- * Created Slug Page
|
||||
|
||||
data CreatedSlug =
|
||||
CreatedSlug
|
||||
{ viewTime :: UTCTime
|
||||
, createdSlug :: Slug
|
||||
, muser :: Maybe User
|
||||
}
|
||||
instance ToJSON CreatedSlug where
|
||||
toJSON cp = toJSON (createdSlug cp)
|
||||
|
||||
slugLink :: Slug -> H.Html
|
||||
slugLink sl = do
|
||||
let s = slugUrl (val sl)
|
||||
i = id sl
|
||||
url = toS ("/comments/" <> urlEncode (toS s))
|
||||
H.a ! A.href (fromString url)
|
||||
$ H.text (toS s)
|
||||
|
||||
instance H.ToMarkup CreatedSlug where
|
||||
toMarkup CreatedSlug{..} =
|
||||
boilerplate (loginWidget muser) $ do
|
||||
H.h2 $ do
|
||||
H.text "Slugs for "
|
||||
slugLink createdSlug
|
||||
-- displayOneSlug slug viewTime
|
||||
|
||||
data SlugsPage =
|
||||
SlugsPage
|
||||
{ spSlug :: Slug
|
||||
, viewTime :: UTCTime
|
||||
, muser :: Maybe User
|
||||
, canCreateSlug :: Bool
|
||||
}
|
||||
|
||||
instance ToJSON SlugsPage where
|
||||
toJSON cp = toJSON (spSlug cp)
|
||||
|
||||
instance H.ToMarkup SlugsPage where
|
||||
toMarkup SlugsPage{..} = do
|
||||
boilerplate (loginWidget muser) $ do
|
||||
let url = slugUrl . val $ spSlug
|
||||
H.h2 $ do
|
||||
H.text "Slugs for "
|
||||
H.a ! A.href (cvt url) $ H.text (toS url)
|
||||
slugForm canCreateSlug url (fmap (toS . nick . val) muser)
|
||||
|
||||
Loading…
Reference in a new issue