adding slugs API
This commit is contained in:
parent
bdd21806dc
commit
ec5c9ca591
9 changed files with 373 additions and 21 deletions
|
@ -41,7 +41,8 @@ import Aggreact.Comments.StoreService (CommentHandler (..))
|
|||
import Aggreact.Comments.Types
|
||||
import Aggreact.Comments.Views
|
||||
import Aggreact.Scopes (Scope (..))
|
||||
import Aggreact.User (User, UserHandler (..))
|
||||
import Aggreact.User (User, UserHandler (..),
|
||||
UserId (..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
|
|
|
@ -52,7 +52,7 @@ where
|
|||
|
||||
import Protolude
|
||||
|
||||
import Aggreact.User (User)
|
||||
import Aggreact.User (User,UserId)
|
||||
|
||||
import qualified Control.Exception as Ex
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..),
|
||||
|
@ -62,6 +62,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..),
|
|||
import Data.Char (isAlphaNum)
|
||||
import Data.Data (Data (..))
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import Data.IxSet.OrphanInstances ()
|
||||
import qualified Data.Text as Text
|
||||
import Data.Time.Clock.Serialize ()
|
||||
import Data.Time.Format ()
|
||||
|
@ -179,17 +180,6 @@ instance FromRow Slug where fromRow = Slug <$> field
|
|||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Slug ': rest) where
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
|
||||
-- *** Field UserId
|
||||
newtype UserId = UserId Text deriving (Eq,Ord,Show,Generic,Data)
|
||||
instance StringConv UserId [Char] where strConv l (UserId sl) = strConv l sl
|
||||
instance StringConv UserId Text where strConv l (UserId sl) = strConv l sl
|
||||
deriving anyclass instance FromJSON UserId
|
||||
deriving anyclass instance ToJSON UserId
|
||||
deriving newtype instance FromField UserId
|
||||
deriving newtype instance ToField UserId
|
||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (UserId ': rest) where
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
|
||||
-- *** Field Content
|
||||
newtype Content = Content Text deriving (Eq,Ord,Show,Generic,Data)
|
||||
instance StringConv Content [Char] where strConv l (Content sl) = strConv l sl
|
||||
|
@ -213,16 +203,8 @@ instance FormI.FromHttpApiData ParentId where
|
|||
Just uuid -> return (ParentId (Just uuid))
|
||||
instance FormI.FromHttpApiData Slug where parseUrlPiece = fmap Slug . FormI.parseUrlPiece
|
||||
instance FormI.FromHttpApiData Content where parseUrlPiece = fmap Content . FormI.parseUrlPiece
|
||||
instance FormI.FromHttpApiData UserId where parseUrlPiece = fmap UserId . FormI.parseUrlPiece
|
||||
|
||||
|
||||
getTerms :: Comment -> [Term]
|
||||
getTerms = fmap Term . Text.split (not . isAlphaNum) . unContent . content . val
|
||||
where unContent (Content x) = x
|
||||
|
||||
-- * Orphan IxSet ToJSON instance
|
||||
instance ( Ord a
|
||||
, ToJSON a
|
||||
, IxSet.Indexable ixs a
|
||||
, Typeable a) => ToJSON (IxSet.IxSet ixs a) where
|
||||
toJSON i = toJSON (IxSet.toList i)
|
||||
|
|
25
src/Aggreact/Slugs.hs
Normal file
25
src/Aggreact/Slugs.hs
Normal file
|
@ -0,0 +1,25 @@
|
|||
{- |
|
||||
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
|
||||
|
||||
This module is here just to re-export sub modules.
|
||||
Because the original module was split because it was too big.
|
||||
|
||||
-}
|
||||
module Aggreact.Slugs
|
||||
( module Aggreact.Slugs.StoreService
|
||||
, module Aggreact.Slugs.Types
|
||||
, module Aggreact.Slugs.Views
|
||||
, module Aggreact.Slugs.Server
|
||||
)
|
||||
where
|
||||
|
||||
import Aggreact.Slugs.StoreService
|
||||
import Aggreact.Slugs.Types
|
||||
import Aggreact.Slugs.Views
|
||||
import Aggreact.Slugs.Server
|
117
src/Aggreact/Slugs/Server.hs
Normal file
117
src/Aggreact/Slugs/Server.hs
Normal file
|
@ -0,0 +1,117 @@
|
|||
-- Local Pragmas
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
-- 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 : 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.Slugs.Server
|
||||
where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Protolude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Aggreact.Authorization (Access (..),
|
||||
AuthorizationHandler (..))
|
||||
import Aggreact.Slugs.StoreService (CommentHandler (..))
|
||||
import Aggreact.Slugs.Types
|
||||
import Aggreact.Slugs.Views
|
||||
import Aggreact.Scopes (Scope (..))
|
||||
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 Servant
|
||||
import Servant.Auth.Server (AuthResult (..))
|
||||
import Servant.Errors
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
|
||||
type SlutAPI =
|
||||
"slugs" :> Get '[JSON] [Slug]
|
||||
:<|> "slugs"
|
||||
:> Capture "slug" Text
|
||||
:> Get '[HTML,JSON] SlugPage
|
||||
:<|> "slugs"
|
||||
:> ReqBody '[JSON, FormUrlEncoded] NewSlug
|
||||
:> PostCreated '[HTML,JSON] CreatedSlug
|
||||
|
||||
data Handlers =
|
||||
Handlers { userHandler :: UserHandler
|
||||
, slugHandler :: SlugHandler
|
||||
, authorizationHandler :: AuthorizationHandler
|
||||
}
|
||||
|
||||
slugAPI :: Handlers -> AuthResult User -> Server CommentAPI
|
||||
slugAPI Handlers{..} authResult =
|
||||
let muser = case authResult of
|
||||
(Authenticated user) -> Just user
|
||||
_ -> Nothing
|
||||
in
|
||||
showSlugs muser authorizationHandler slugHandler
|
||||
:<|> showSlug muser authorizationHandler slugHandler
|
||||
:<|> postNewSlug muser authorizationHandler slugHandler
|
||||
|
||||
showSlugs :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler SlugsPage
|
||||
showSlugs muser AuthorizationHandler{..} CommentHandler{..} s = do
|
||||
_ <- filterAccess (Scope "slug" Read) muser
|
||||
cvs <- liftIO $ commentsView (Slug s)
|
||||
now <- liftIO getCurrentTime
|
||||
liftIO $ print cvs
|
||||
return SlugsPage { url = s
|
||||
, viewTime = now
|
||||
, muser = muser
|
||||
, canComment = hasScope (Scope "comment" Read) muser
|
||||
}
|
||||
|
||||
showSlug :: Maybe User
|
||||
-> AuthorizationHandler
|
||||
-> CommentHandler
|
||||
-> Handler [Slug]
|
||||
showSlug muser AuthorizationHandler{..} ch = do
|
||||
_ <- filterAccess (Scope "comment" Read) muser
|
||||
liftIO (getSlugs ch)
|
||||
|
||||
muserToUserId :: Maybe User -> UserId
|
||||
muserToUserId Nothing = UserId (toS minimalId)
|
||||
muserToUserId (Just (Entity i _ _)) = UserId (toS i)
|
||||
|
||||
|
||||
postNewSlug :: Maybe User
|
||||
-> AuthorizationHandler
|
||||
-> CommentHandler
|
||||
-> NewComment
|
||||
-> Handler CreatedComment
|
||||
postNewSlug muser AuthorizationHandler{..} ch nc = do
|
||||
_ <- filterAccess (Scope "comment" Write) muser
|
||||
let uid = muserToUserId muser
|
||||
CreatedComment <$> liftIO getCurrentTime
|
||||
<*> liftIO (createComment ch (nc { userid = uid }))
|
||||
<*> return muser
|
0
src/Aggreact/Slugs/StoreService.hs
Normal file
0
src/Aggreact/Slugs/StoreService.hs
Normal file
157
src/Aggreact/Slugs/Types.hs
Normal file
157
src/Aggreact/Slugs/Types.hs
Normal file
|
@ -0,0 +1,157 @@
|
|||
-- Local Pragmas
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# 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 #-} -- blabla do ... instead of blabla $ do ...
|
||||
{-# LANGUAGE DeriveGeneric #-} -- deriving ToJSON ...
|
||||
{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies
|
||||
{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- newtype Id = Id Text deriving (StringConv Id String)
|
||||
{-# 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
|
||||
{-# LANGUAGE StandaloneDeriving #-} -- write deriving instance ...
|
||||
{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y)
|
||||
{- |
|
||||
Module : Aggreact.Slugs.StoreService
|
||||
Description : CommentStore service
|
||||
Copyright : (c) 2018, Yann Esposito
|
||||
License : ISC
|
||||
Maintainer : yann.esposito@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
Comment datastructures with class instances here to prevent most Orphan
|
||||
instances.
|
||||
|
||||
- A @Slug@ is a NewSlug with metas
|
||||
- A @SlugView@ is a slug along its creator infos
|
||||
- A @NewSlug@ is the main infos for a Slug
|
||||
|
||||
-}
|
||||
|
||||
module Aggreact.Comments.Types
|
||||
where
|
||||
|
||||
|
||||
import Protolude
|
||||
|
||||
import Aggreact.User (User)
|
||||
|
||||
import qualified Control.Exception as Ex
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..),
|
||||
defaultOptions,
|
||||
genericParseJSON,
|
||||
genericToJSON)
|
||||
import Data.Char (isAlphaNum)
|
||||
import Data.Data (Data (..))
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import qualified Data.Text as Text
|
||||
import Data.Time.Clock.Serialize ()
|
||||
import Data.Time.Format ()
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.UUID (UUID)
|
||||
import qualified Data.UUID as UUID
|
||||
import Database.SQLite.Simple (SQLData (..))
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.FromRow (FromRow (..), field)
|
||||
import Database.SQLite.Simple.ToRow (ToRow (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Database.Store (DefaultMetas (..), Entity (..), Id (..))
|
||||
import Database.Store.Backend.SQLite as SQL
|
||||
import qualified Generics.SOP as SOP
|
||||
import qualified Web.FormUrlEncoded as Form
|
||||
import qualified Web.HttpApiData as FormI
|
||||
|
||||
|
||||
-- * Slug
|
||||
|
||||
-- | A Slug is a NewSlug with metas
|
||||
type Slug = Entity DefaultMetas NewSlug
|
||||
|
||||
-- Slug Indexing
|
||||
type Slugs = IxSet.IxSet SlugIxs Slug
|
||||
type SlugIxs = '[Id,Slug,UserId]
|
||||
instance IxSet.Indexable SlugIxs Slug where
|
||||
indices = IxSet.ixList
|
||||
(IxSet.ixGen (Proxy :: Proxy Id))
|
||||
(IxSet.ixGen (Proxy :: Proxy Slug))
|
||||
(IxSet.ixGen (Proxy :: Proxy UserId))
|
||||
|
||||
-- ** SlugView
|
||||
|
||||
-- | A SlugView is a slug along its creator infos
|
||||
data SlugView = SlugView Slug User
|
||||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
|
||||
-- Web
|
||||
deriving instance ToJSON SlugView
|
||||
-- SQLite Select
|
||||
instance FromRow SlugView where fromRow = SlugView <$> fromRow <*> fromRow
|
||||
-- Indexing
|
||||
type SlugViews = IxSet.IxSet SlugViewIxs SlugView
|
||||
type SlugViewIxs = '[Id,Slug,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 UserId))
|
||||
|
||||
-- ** NewSlug
|
||||
|
||||
-- | A NewSlug is the main infos for a Slug
|
||||
data NewSlug =
|
||||
NewSlug
|
||||
{ slug :: Slug -- ^ Text (URL)
|
||||
, userid :: UserId -- ^ UUID
|
||||
} deriving (Generic,Typeable,Data,Eq,Ord,Show)
|
||||
|
||||
-- Web
|
||||
instance FromJSON NewSlug where parseJSON = genericParseJSON defaultOptions
|
||||
instance ToJSON NewSlug where toJSON = genericToJSON defaultOptions
|
||||
instance Form.FromForm NewSlug where
|
||||
fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
|
||||
|
||||
-- Store / SQLite
|
||||
instance SOP.Generic NewSlug
|
||||
instance SOP.HasDatatypeInfo NewSlug
|
||||
deriving instance SQLiteSchemas NewSlug
|
||||
instance FromRow NewSlug where fromRow = SQL.genericFromRow
|
||||
instance ToRow NewSlug where toRow = SQL.genericToRow
|
||||
|
||||
-- Slugs RAM Indexing
|
||||
type NewSlugIxs = '[Slug,UserId]
|
||||
instance IxSet.Indexable NewSlugIxs Slug where
|
||||
indices = IxSet.ixList
|
||||
(IxSet.ixGen (Proxy :: Proxy Slug))
|
||||
(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
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
|
||||
instance FormI.FromHttpApiData Slug where parseUrlPiece = fmap Slug . FormI.parseUrlPiece
|
0
src/Aggreact/Slugs/Views.hs
Normal file
0
src/Aggreact/Slugs/Views.hs
Normal file
|
@ -176,6 +176,20 @@ instance ToRow NewUser where toRow = SQL.genericToRow
|
|||
|
||||
type User = Entity DefaultMetas NewUser
|
||||
|
||||
|
||||
-- *** Field UserId
|
||||
newtype UserId = UserId Text deriving (Eq,Ord,Show,Generic,Data)
|
||||
instance StringConv UserId [Char] where strConv l (UserId sl) = strConv l sl
|
||||
instance StringConv UserId Text where strConv l (UserId sl) = strConv l sl
|
||||
deriving anyclass instance FromJSON UserId
|
||||
deriving anyclass instance ToJSON UserId
|
||||
deriving newtype instance FromField UserId
|
||||
deriving newtype instance ToField UserId
|
||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (UserId ': rest) where
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
instance FormI.FromHttpApiData UserId where
|
||||
parseUrlPiece = fmap UserId . FormI.parseUrlPiece
|
||||
|
||||
-- * Usage for DB
|
||||
|
||||
type UserSQLiteStore = SQLiteStore IO DefaultMetas NewUser
|
||||
|
|
56
src/Data/IxSet/OrphanInstances.hs
Normal file
56
src/Data/IxSet/OrphanInstances.hs
Normal file
|
@ -0,0 +1,56 @@
|
|||
-- Local Pragmas
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# 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 DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{- |
|
||||
Module : Data.IxSet.OrphanInstances
|
||||
Description : Orphan Instances for IxSet
|
||||
Copyright : (c) 2018, Yann Esposito
|
||||
License : ISC
|
||||
Maintainer : yann.esposito@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
-}
|
||||
|
||||
module Data.IxSet.OrphanInstances
|
||||
where
|
||||
|
||||
import Protolude
|
||||
|
||||
import Data.Aeson (ToJSON (..))
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
-- * Orphan IxSet ToJSON instance
|
||||
instance ( Ord a
|
||||
, ToJSON a
|
||||
, IxSet.Indexable ixs a
|
||||
, Typeable a) => ToJSON (IxSet.IxSet ixs a) where
|
||||
toJSON i = toJSON (IxSet.toList i)
|
Loading…
Reference in a new issue