Added slugs in the API
This commit is contained in:
parent
fdc99d432b
commit
d23918a032
6 changed files with 73 additions and 76 deletions
|
@ -12,6 +12,7 @@ main = do
|
|||
{ cookieIsSecure = NotSecure
|
||||
, cookieXsrfSetting = Nothing
|
||||
, cookieSameSite = AnySite }
|
||||
, slugDBConf = SQLiteConf "aggreact.db" "slugs"
|
||||
, userDBConf = SQLiteConf "aggreact.db" "users"
|
||||
, commentDBConf = SQLiteConf "aggreact.db" "comments"
|
||||
, authorizationStrategy = Anybody
|
||||
|
|
|
@ -46,6 +46,7 @@ import Aggreact.Auth
|
|||
import Aggreact.Authorization
|
||||
import Aggreact.Comments
|
||||
import Aggreact.Homepage
|
||||
import Aggreact.Slugs
|
||||
import Aggreact.User
|
||||
|
||||
import Network.Wai (Application)
|
||||
|
@ -59,6 +60,7 @@ data Conf =
|
|||
, jwtKeyFilePath :: FilePath
|
||||
, cookieSettings :: CookieSettings
|
||||
, userDBConf :: UserDBConf
|
||||
, slugDBConf :: SlugDBConf
|
||||
, commentDBConf :: CommentDBConf
|
||||
, authorizationStrategy :: AuthorizationStrategy
|
||||
} deriving (Eq, Show)
|
||||
|
@ -70,6 +72,7 @@ type API auths =
|
|||
type Authenticated =
|
||||
HomepageAPI
|
||||
:<|> CommentAPI
|
||||
:<|> SlugAPI
|
||||
:<|> UserAPI
|
||||
|
||||
serverAuthenticated :: Settings
|
||||
|
@ -78,11 +81,13 @@ serverAuthenticated :: Settings
|
|||
serverAuthenticated Settings{..} authresult =
|
||||
homepageAPI commentHandler authresult
|
||||
:<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler authorizationHandler) authresult
|
||||
:<|> slugAPI (Aggreact.Slugs.Handlers userHandler slugHandler authorizationHandler) authresult
|
||||
:<|> userAPI userHandler authresult
|
||||
|
||||
data Settings =
|
||||
Settings { cookieSettings :: CookieSettings
|
||||
, jwtSettings :: JWTSettings
|
||||
, slugHandler :: SlugHandler
|
||||
, userHandler :: UserHandler
|
||||
, commentHandler :: CommentHandler
|
||||
, authorizationHandler :: AuthorizationHandler
|
||||
|
@ -104,6 +109,7 @@ initialize :: Conf -> IO (Settings,Application)
|
|||
initialize Conf{..} = do
|
||||
uh <- newUserHandler userDBConf defaultAdminUser
|
||||
ch <- newCommentHandler (dbstore uh) commentDBConf
|
||||
sh <- newSlugHandler (dbstore uh) slugDBConf
|
||||
ah <- newAuthorizationHandler authorizationStrategy
|
||||
myKey <- readKey jwtKeyFilePath
|
||||
let jwtSettings = defaultJWTSettings myKey
|
||||
|
@ -112,6 +118,7 @@ initialize Conf{..} = do
|
|||
let settings =
|
||||
Settings { jwtSettings = jwtSettings
|
||||
, cookieSettings = cookieSettings
|
||||
, slugHandler = sh
|
||||
, userHandler = uh
|
||||
, commentHandler = ch
|
||||
, authorizationHandler = ah
|
||||
|
|
|
@ -79,14 +79,14 @@ strToScope txt =
|
|||
unloggedScopes :: AuthorizationStrategy -> Scopes
|
||||
unloggedScopes Anybody =
|
||||
[ "comment"
|
||||
, "stub"]
|
||||
, "slug:read"]
|
||||
& traverse strToScope
|
||||
& fmap Set.fromList
|
||||
& fromMaybe Set.empty
|
||||
|
||||
unloggedScopes LoggedInOnly =
|
||||
[ "comment:read"
|
||||
, "stub:read"]
|
||||
, "slug:read"]
|
||||
& traverse strToScope
|
||||
& fmap Set.fromList
|
||||
& fromMaybe Set.empty
|
||||
|
@ -94,7 +94,7 @@ unloggedScopes LoggedInOnly =
|
|||
scopesFor :: NewUser -> AuthorizationStrategy -> Set Scope
|
||||
scopesFor _ Anybody =
|
||||
[ "comment"
|
||||
, "homepage"]
|
||||
, "slug:read"]
|
||||
& traverse strToScope
|
||||
& fmap Set.fromList
|
||||
& fromMaybe Set.empty
|
||||
|
@ -102,9 +102,9 @@ scopesFor _ Anybody =
|
|||
scopesFor u LoggedInOnly =
|
||||
let scs = case role u of
|
||||
User -> [ "comment"
|
||||
, "stub:read"]
|
||||
, "slug:read"]
|
||||
Admin -> [ "comment"
|
||||
, "stub"]
|
||||
, "slug"]
|
||||
in
|
||||
scs
|
||||
& traverse strToScope
|
||||
|
|
|
@ -41,19 +41,22 @@ import Aggreact.Scopes (Scope (..))
|
|||
import Aggreact.Slugs.StoreService (SlugHandler (..))
|
||||
import Aggreact.Slugs.Types
|
||||
import Aggreact.Slugs.Views
|
||||
import Aggreact.User (User, UserHandler (..))
|
||||
import Aggreact.User (User, UserHandler (..),
|
||||
UserId (..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import Data.Time (getCurrentTime)
|
||||
import qualified Data.UUID as UUID
|
||||
import Database.Store (Entity (..), Id (..), minimalId)
|
||||
import Database.SQLite.Simple (NamedParam ((:=)))
|
||||
import Database.Store (Entity (..), minimalId)
|
||||
import Database.Store.Backend.SQLite (SearchQuery (Filter),
|
||||
SearchResult (SR))
|
||||
import qualified Database.Store.Backend.SQLite as SQL
|
||||
import Servant
|
||||
import Servant.Auth.Server (AuthResult (..))
|
||||
import Servant.Errors
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
|
||||
type SlutAPI =
|
||||
type SlugAPI =
|
||||
"slugs" :> Get '[JSON] [Slug]
|
||||
:<|> "slugs"
|
||||
:> Capture "slug" Text
|
||||
|
@ -78,39 +81,49 @@ slugAPI Handlers{..} authResult =
|
|||
:<|> showSlug muser authorizationHandler slugHandler
|
||||
:<|> postNewSlug muser authorizationHandler slugHandler
|
||||
|
||||
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
|
||||
liftIO $ print cvs
|
||||
return SlugsPage { url = s
|
||||
, viewTime = now
|
||||
, muser = muser
|
||||
, canComment = hasScope (Scope "comment" Read) muser
|
||||
}
|
||||
|
||||
showSlugs :: Maybe User
|
||||
-> AuthorizationHandler
|
||||
-> CommentHandler
|
||||
-> SlugHandler
|
||||
-> Handler [Slug]
|
||||
showSlugs muser AuthorizationHandler{..} ch = do
|
||||
showSlugs muser AuthorizationHandler{..} sh = do
|
||||
_ <- filterAccess (Scope "comment" Read) muser
|
||||
liftIO (getSlugs ch)
|
||||
liftIO (getSlugs sh)
|
||||
|
||||
showSlug :: Maybe User
|
||||
-> AuthorizationHandler
|
||||
-> SlugHandler
|
||||
-> Text
|
||||
-> Handler SlugPage
|
||||
showSlug muser AuthorizationHandler{..} SlugHandler{..} slUrl = do
|
||||
_ <- filterAccess (Scope "slug" Read) muser
|
||||
(SR (SQL.Paginated slugs _ _)) <- liftIO $ searchSlugs (Filter {params = ["slugUrl" := slUrl]})
|
||||
case slugs of
|
||||
[] -> notFound "Cannot find the slug you're looking for"
|
||||
(s:[]) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
return SlugPage
|
||||
{ spSlug = s
|
||||
, viewTime = now
|
||||
, muser = muser
|
||||
, canCreateSlug = hasScope (Scope "slug" Write) muser
|
||||
}
|
||||
_ -> internalServerError "Something went wrong, duplicate slugs..."
|
||||
|
||||
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 }))
|
||||
-> SlugHandler
|
||||
-> NewSlug
|
||||
-> Handler CreatedSlug
|
||||
postNewSlug muser AuthorizationHandler{..} SlugHandler{..} ns = do
|
||||
_ <- filterAccess (Scope "slug" Write) muser
|
||||
(SR (SQL.Paginated slugs _ _)) <- liftIO $ searchSlugs (Filter {params = ["slugUrl" := (slugUrl ns)]})
|
||||
if null slugs
|
||||
then CreatedSlug
|
||||
<$> liftIO getCurrentTime
|
||||
<*> liftIO (createSlug (ns { userid = muserToUserId muser }))
|
||||
<*> return muser
|
||||
else forbidden "This slug already exists."
|
||||
|
|
|
@ -48,14 +48,11 @@ 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 (UTCTime)
|
||||
import Data.Time.Clock.Serialize ()
|
||||
import Data.Time.Format ()
|
||||
import qualified Data.UUID as UUID
|
||||
import Database.Store (DefaultMetas (..), Entity (..))
|
||||
import Database.Store (Entity (..))
|
||||
import Text.Blaze.Html5 ((!))
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
|
@ -63,20 +60,20 @@ 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
|
||||
{ spSlug :: Slug
|
||||
, viewTime :: UTCTime
|
||||
, muser :: Maybe User
|
||||
, canCreateSlug :: Bool
|
||||
}
|
||||
|
||||
instance ToJSON SlugPage where
|
||||
toJSON sp = toJSON (slug sp)
|
||||
toJSON sp = toJSON (spSlug sp)
|
||||
|
||||
instance H.ToMarkup SlugPage where
|
||||
toMarkup SlugPage{..} = boilerplate (loginWidget muser) $ do
|
||||
let sl = slug & val & slugUrl & toS
|
||||
let sl = spSlug & val & slugUrl & toS
|
||||
H.h2 $ do
|
||||
H.a ! A.href ("/comments/" <> cvt (urlEncode (toS sl))) $ H.text "Slug"
|
||||
H.text " for "
|
||||
|
@ -112,7 +109,6 @@ instance ToJSON CreatedSlug where
|
|||
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)
|
||||
|
@ -124,24 +120,3 @@ instance H.ToMarkup CreatedSlug where
|
|||
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)
|
||||
|
||||
|
|
|
@ -71,6 +71,7 @@ update = do
|
|||
{ cookieIsSecure = NotSecure
|
||||
, cookieXsrfSetting = Nothing
|
||||
, cookieSameSite = AnySite }
|
||||
, slugDBConf = SQLiteConf "aggreact.db" "slugs"
|
||||
, userDBConf = SQLiteConf "aggreact.db" "users"
|
||||
, commentDBConf = SQLiteConf "aggreact.db" "comments"
|
||||
, authorizationStrategy = Anybody
|
||||
|
|
Loading…
Reference in a new issue