yogsototh/aggreact
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

adding slugs API

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-04-13 18:19:04 +02:00
parent bdd21806dc
commit ec5c9ca591
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
9 changed files with 373 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
src/Aggreact/Comments/Server.hs
View file

@ -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

22
src/Aggreact/Comments/Types.hs
View file

@ -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
View 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
View 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
View file

157
src/Aggreact/Slugs/Types.hs Normal file
View 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
View file

14
src/Aggreact/User.hs
View 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
View 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)