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

Added slugs in the API

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-04-13 20:51:06 +02:00
parent fdc99d432b
commit d23918a032
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
6 changed files with 73 additions and 76 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src-exe/Main.hs
View file

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

7
src/Aggreact.hs
View file

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

10
src/Aggreact/Authorization.hs
View file

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

87
src/Aggreact/Slugs/Server.hs
View file

@ -35,25 +35,28 @@ where
import Protolude
--------------------------------------------------------------------------------
import Aggreact.Authorization (Access (..),
AuthorizationHandler (..))
import Aggreact.Scopes (Scope (..))
import Aggreact.Slugs.StoreService (SlugHandler (..))
import Aggreact.Authorization (Access (..),
AuthorizationHandler (..))
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 Data.Time (getCurrentTime)
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.Auth.Server (AuthResult (..))
import Servant.Errors
import Servant.HTML.Blaze (HTML)
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 }))
<*> return muser
-> 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."

43
src/Aggreact/Slugs/Views.hs
View file

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

1
src/DevelMain.hs
View file

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