finished getComment, deleteComment, postFavorited, deleteFavorited.

parent 1e14a681
......@@ -57,11 +57,11 @@ type ArticlesAPI =
:<|> "articles"
:> Capture "slug" Text
:> "favorite"
:> PostNoContent '[ JSON] NoContent
:> PostNoContent '[ JSON] ResponseArticle
:<|> "articles"
:> Capture "slug" Text
:> "favorite"
:> DeleteNoContent '[ JSON] NoContent
:> DeleteNoContent '[ JSON] ResponseArticle
articlesProxy :: Proxy ArticlesAPI
articlesProxy = Proxy
......@@ -75,7 +75,10 @@ articlesApi authres =
:<|> deleteArticleSlugCoach authres
:<|> putArticleSlugCoach authres
:<|> getCommentsSlugCoach authres
:<|> panic ""
:<|> postCommentSlugCoach authres
:<|> deleteCommentSlugIdCoach authres
:<|> postFavoriteArticleCoach authres
:<|> deleteFavoriteArticleCoach authres
articlesServer :: Configuration -> AuthResult User -> Server ArticlesAPI
articlesServer conf authres =
......
......@@ -62,7 +62,7 @@ getArticleSlugCoach authres slug = do
1
0
case articles of
[] -> throwError err404 {errBody = "No such article."}
[] -> throwError err404 {errBody = encodeRespError "No such article."}
x:_ -> return $ ResponseArticle $ resultQueryToResponseArticle x
getArticlesFeed ::
......@@ -87,7 +87,8 @@ getArticlesFeed (Authenticated User {..}) mlimit moffset = do
ResponseMultiArticle
(map resultQueryToResponseArticle articles)
(length articles)
getArticlesFeed _ _ _ = throwError err401 {errBody = "Only authenticated user."}
getArticlesFeed _ _ _ =
throwError err401 {errBody = encodeRespError "Only authenticated user."}
postArticleCreateCoach ::
MonadIO m
......@@ -117,9 +118,10 @@ postArticleCreateCoach (Authenticated User {..}) (RequestCreateArticle RequestCr
1
0
case articles of
[] -> throwError err410 {errBody = "Should be created, but now it's gone."}
[] -> throwError err410 {errBody = encodeRespError "Should be created, but now it's gone."}
x:_ -> return $ ResponseArticle $ resultQueryToResponseArticle x
postArticleCreateCoach _ _ = throwError err401
postArticleCreateCoach _ _ =
throwError err401 {errBody = encodeRespError "Only authenticated user."}
deleteArticleSlugCoach ::
MonadIO m
......@@ -128,7 +130,10 @@ deleteArticleSlugCoach ::
-> CoachT m NoContent
deleteArticleSlugCoach (Authenticated User {..}) slug = do
users <- runDb $ isArticleAuthor userUsername slug
when (null users) $ throwError err401 {errBody = "Not the author or article doesn't exist."}
when (null users) $
throwError
err401
{errBody = encodeRespError "Not the author or article doesn't exist."}
runDb $ deleteArticle slug
return NoContent
deleteArticleSlugCoach _ _ = throwError err401
......@@ -142,8 +147,11 @@ putArticleSlugCoach ::
putArticleSlugCoach (Authenticated User {..}) slug (RequestUpdateArticle req@RequestUpdateArticleBody {..}) = do
users <- runDb $ isArticleAuthor userUsername slug
when (null users) $
throwError err401 {errBody = "Not the author or article doesn't exist."}
when (reqUpdateIsEmpty req) $ throwError err422 {errBody = "u wot m8?"}
throwError
err401
{errBody = encodeRespError "Not the author or article doesn't exist."}
when (reqUpdateIsEmpty req) $
throwError err422 {errBody = encodeRespError "u wot m8?"}
articles <-
runDb $ do
updateArticle
......@@ -161,7 +169,10 @@ putArticleSlugCoach (Authenticated User {..}) slug (RequestUpdateArticle [email protected]
1
0
case articles of
[] -> throwError err410 {errBody = "Should be created, but now it's gone."}
[] ->
throwError
err410
{errBody = encodeRespError "Should be created, but now it's gone."}
x:_ -> return $ ResponseArticle $ resultQueryToResponseArticle x
putArticleSlugCoach _ _ _ = throwError err401
......@@ -176,18 +187,105 @@ getCommentsSlugCoach ::
getCommentsSlugCoach authres slug = do
marticle <- runDb $ getBy $ UniqueSlug slug
when (isNothing marticle) $
throwError err404 {errBody = "There's no such thing."}
throwError err404 {errBody = encodeRespError "There's no such thing."}
comments <-
runDb $ selectComments (userUsername <$> authresToMaybe authres) slug
return $ ResponseMultiComment $ map resultQueryToResponseComment comments
postCommentSlugCoach :: MonadIO m => AuthResult User -> Text -> RequestComment -> CoachT m ResponseComment
postCommentSlugCoach (Authenticated User {..}) slug reqcomment = do
postCommentSlugCoach ::
MonadIO m
=> AuthResult User
-> Text
-> RequestComment
-> CoachT m ResponseComment
postCommentSlugCoach (Authenticated User {..}) slug (RequestComment (RequestCommentBody body)) = do
marticle <- runDb $ getBy $ UniqueSlug slug
when (isNothing marticle) $
throwError err404 {errBody = "There's no such thing."}
panic ""
postCommentSlugCoach _ _ _ = throwError err401
throwError err404 {errBody = encodeRespError "There's no such thing."}
mcomment <- runDb $ insertComment userUsername slug body
case mcomment of
Just comment ->
return $ ResponseComment $ resultQueryToResponseComment comment
Nothing -> throwError err410 {errBody = encodeRespError "Now it's gone."}
postCommentSlugCoach _ _ _ =
throwError err401 {errBody = encodeRespError "Only authorised something."}
deleteCommentSlugIdCoach ::
MonadIO m
=> AuthResult User
-> Text
-> Int64
-> CoachT m NoContent
deleteCommentSlugIdCoach (Authenticated User {..}) slug id = do
comments <-
runDb $ selectCommentByUsernameSlugId userUsername slug $ toSqlKey id
when (null comments) $
throwError
err401
{ errBody =
encodeRespError
"Perhaps you're not allowed or perhaps there's no such thing."
}
runDb $ deleteComment $ toSqlKey id
return NoContent
deleteCommentSlugIdCoach _ _ _ =
throwError err401 {errBody = encodeRespError "Only authorised something."}
postFavoriteArticleCoach :: MonadIO m => AuthResult User -> Text -> CoachT m ResponseArticle
postFavoriteArticleCoach (Authenticated User {..}) slug = do
favs <- runDb $ isFavoritingArticle userUsername slug
unless (null favs) $
throwError
err401
{ errBody =
encodeRespError
"Perhaps you've favorited this one before or perhaps there's no such thing."
}
runDb $ insertFavorited userUsername slug
articles <-
runDb $
selectArticles
(Just userUsername)
False
(Just slug)
Nothing
Nothing
Nothing
1
0
case articles of
[] -> throwError err404 {errBody = encodeRespError "No such article."}
x:_ -> return $ ResponseArticle $ resultQueryToResponseArticle x
postFavoriteArticleCoach _ _ =
throwError err401 {errBody = encodeRespError "Only authorised something."}
deleteFavoriteArticleCoach :: MonadIO m => AuthResult User -> Text -> CoachT m ResponseArticle
deleteFavoriteArticleCoach (Authenticated User {..}) slug = do
favs <- runDb $ isFavoritingArticle userUsername slug
when (null favs) $
throwError
err401
{ errBody =
encodeRespError
"Perhaps you haven't favorited this one before or perhaps there's no such thing."
}
runDb $ deleteFavorited userUsername slug
articles <-
runDb $
selectArticles
(Just userUsername)
False
(Just slug)
Nothing
Nothing
Nothing
1
0
case articles of
[] -> throwError err404 {errBody = encodeRespError "No such article."}
x:_ -> return $ ResponseArticle $ resultQueryToResponseArticle x
deleteFavoriteArticleCoach _ _ =
throwError err401 {errBody = encodeRespError "Only authorised something."}
resultQueryToResponseComment ::
(Entity Comment, Entity User, Value Bool) -> ResponseCommentBody
......
......@@ -22,14 +22,14 @@ getUserProfileCoach ::
-> CoachT m ResponseProfile
getUserProfileCoach authres profilename = do
muser <- runDb $ getBy $ UniqueUsername profilename
when (isNothing muser) $ throwError err404 {errBody = "No such profile."}
when (isNothing muser) $ throwError err404 {errBody = encodeRespError "No such profile."}
followings <-
runDb $
selectFollowsByUsernameAndProfilename
(userUsername <$> authresToMaybe authres)
profilename
case followings of
[] -> throwError err410
[] -> throwError err410 {errBody = encodeRespError "Is gone!"}
((Entity _ user, Value follow):_) -> do
return $
ResponseProfile $
......@@ -44,22 +44,24 @@ postUserFollowCoach ::
postUserFollowCoach (Authenticated user) profilename = do
muser <- runDb $ getBy $ UniqueUsername profilename
when (isNothing muser) $
throwError err404 {errBody = "There are no such user."}
throwError err404 {errBody = encodeRespError "There are no such user."}
follows <- runDb $ selectFollows (userUsername user) profilename
unless (null follows) $
throwError err409 {errBody = "Already followed that profile."}
throwError err409 {errBody = encodeRespError "Already followed that profile."}
runDb $ insertFollows (userUsername user) profilename
return NoContent
postUserFollowCoach _ _ = throwError err401
postUserFollowCoach _ _ =
throwError err401 {errBody = encodeRespError "Not allowed to access."}
deleteUserFollowCoach :: MonadIO m => AuthResult User -> Text -> CoachT m NoContent
deleteUserFollowCoach (Authenticated user) profilename = do
muser <- runDb $ getBy $ UniqueUsername profilename
when (isNothing muser) $
throwError err404 {errBody = "There are no such user."}
throwError err404 {errBody = encodeRespError "There are no such user."}
follows <- runDb $ selectFollows (userUsername user) profilename
when (null follows) $
throwError err404 {errBody = "You are not following that profile"}
throwError err404 {errBody = encodeRespError "You are not following that profile"}
runDb $ deleteFollows (userUsername user) profilename
return NoContent
deleteUserFollowCoach _ _ = throwError err401
deleteUserFollowCoach _ _ =
throwError err401 {errBody = encodeRespError "Not allowed to access."}
......@@ -2,7 +2,7 @@
{-# LANGUAGE RecordWildCards #-}
module Coach.Users where
import Protolude
import Lib.Prelude
import Crypto.BCrypt
import Data.ByteString.Char8 (pack)
......@@ -48,7 +48,8 @@ postRegistrationCoach (RequestRegistration reqreg) = do
existings <- runDb (selectUserByUsernameEmail username email)
case existings of
[] -> return ()
_ -> throwError err409 { errBody = "User already exists."}
_ ->
throwError err409 {errBody = encodeRespError "User already exists."}
generateToken ::
MonadIO m
......@@ -76,7 +77,7 @@ postLoginCoach (RequestLogin (RequestLoginBody email password)) = do
(validatePassword
((pack . unpack) (userPassword user))
((pack . unpack) (password))) $
throwError err401 {errBody = "No such thing."}
throwError err401 {errBody = encodeRespError "No such thing."}
token <- generateToken user
return $
ResponseUser $
......@@ -87,7 +88,8 @@ postLoginCoach (RequestLogin (RequestLoginBody email password)) = do
(userBio user)
(userImage user)
where
notFoundIfNothing Nothing = throwError err401 {errBody = "No such thing."}
notFoundIfNothing Nothing =
throwError err401 {errBody = encodeRespError "No such thing."}
notFoundIfNothing (Just x) = return x
getUserInformationCoach :: MonadIO m => AuthResult User -> CoachT m ResponseUser
......@@ -101,11 +103,12 @@ getUserInformationCoach (Authenticated user) = do
(userUsername user)
(userBio user)
(userImage user)
getUserInformationCoach _ = throwError err401
getUserInformationCoach _ =
throwError err401 {errBody = encodeRespError "Not qualified to access"}
putUserInformationCoach :: MonadIO m => AuthResult User -> RequestUpdateUser -> CoachT m ResponseUser
putUserInformationCoach (Authenticated _) (RequestUpdateUser (RequestUpdateUserBody Nothing Nothing Nothing Nothing Nothing)) =
throwError err422 { errBody = "What are you going to update?"}
throwError err422 { errBody = encodeRespError "What are you going to update?"}
putUserInformationCoach (Authenticated user) (RequestUpdateUser requpdate) = do
let newUsernameEmail old (Just x) =
if old == x
......@@ -118,7 +121,7 @@ putUserInformationCoach (Authenticated user) (RequestUpdateUser requpdate) = do
newUsernameEmail (userEmail user) (requpdtuserbodyEmail requpdate)
existings <-
runDb $ selectUserByMaybeUsernameEmail perhapsnewusername perhapsnewemail
unless (null existings) $ throwError err409 {errBody = "Already used."}
unless (null existings) $ throwError err409 {errBody = encodeRespError "Already used."}
runDb $
updateUser
(userUsername user)
......@@ -138,4 +141,5 @@ putUserInformationCoach (Authenticated user) (RequestUpdateUser requpdate) = do
(userUsername u)
(userBio u)
(userImage u)
putUserInformationCoach _ _ = throwError err401
putUserInformationCoach _ _ =
throwError err401 {errBody = encodeRespError "Not allowed to access."}
......@@ -235,3 +235,86 @@ updateArticle slug mtitle mdesc mbody = do
where
updateByMaybe Nothing ent acc = acc =. ent ^. acc
updateByMaybe (Just x) _ acc = acc =. val x
selectCommentByUsernameSlugId ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Text
-> Text
-> Key Comment
-> ReaderT backend m [Entity Comment]
selectCommentByUsernameSlugId username slug id = do
select $
from $ \(user `InnerJoin` comment `InnerJoin` article) -> do
on $ article ^. ArticleId ==. comment ^. CommentArticleId
on $ user ^. UserId ==. comment ^. CommentUserId
where_ $ user ^. UserUsername ==. val username
where_ $ article ^. ArticleSlug ==. val slug
where_ $ comment ^. CommentId ==. val id
return comment
deleteComment ::
( PersistUniqueWrite backend
, PersistQueryWrite backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Key Comment
-> ReaderT backend m ()
deleteComment id =
delete $ from $ \comment -> do where_ $ comment ^. CommentId ==. val id
isFavoritingArticle ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Text
-> Text
-> ReaderT backend m [Entity Favorited]
isFavoritingArticle username slug = do
select $
from $ \(user `InnerJoin` favorited `InnerJoin` article) -> do
on $ article ^. ArticleId ==. favorited ^. FavoritedArticleId
on $ user ^. UserId ==. favorited ^. FavoritedUserId
where_ $ user ^. UserUsername ==. val username
where_ $ article ^. ArticleSlug ==. val slug
return favorited
insertFavorited ::
( PersistUniqueWrite backend
, PersistQueryWrite backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Text
-> Text
-> ReaderT backend m ()
insertFavorited username slug = do
insertSelect $
from $ \(user, article) -> do
where_ $ user ^. UserUsername ==. val username
where_ $ article ^. ArticleSlug ==. val slug
return $ Favorited <# (user ^. UserId) <&> (article ^. ArticleId)
deleteFavorited ::
( PersistUniqueWrite backend
, PersistQueryWrite backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Text
-> Text
-> ReaderT backend m ()
deleteFavorited username slug = do
delete $ from $ \favorited -> do
where_ $ exists $
from $ \(user, article) -> do
where_ $ favorited ^. FavoritedUserId ==. user ^. UserId
where_ $ favorited ^. FavoritedArticleId ==. article ^. ArticleId
where_ $ user ^. UserUsername ==. val username
where_ $ article ^. ArticleSlug ==. val slug
......@@ -6,6 +6,7 @@ module Que.Comments where
import Lib.Prelude hiding (from, get, on, (<&>))
import Data.Time
import Database.Esqueleto
import Model
......@@ -40,3 +41,42 @@ selectComments musername slug = do
where_ $ article ^. ArticleSlug ==. val slug
orderBy [asc (comment ^. CommentId)]
return (comment, commentator, following musername)
insertComment ::
( BaseBackend backend ~ SqlBackend
, MonadIO m
, BackendCompatible SqlBackend backend
, PersistQueryRead backend
, PersistUniqueRead backend
, PersistStoreWrite backend
)
=> Text
-> Text
-> Text
-> ReaderT backend m (Maybe (Entity Comment, Entity User, Value Bool))
insertComment username slug body = do
now <- liftIO getCurrentTime
something <-
select $
from $ \(user, article) -> do
let narcissticprick Nothing = val False
narcissticprick (Just uname) =
case_
[ when_
(exists $
from $ \(u, f) -> do
where_ $ u ^. UserId ==. f ^. FollowFollowerId
where_ $ u ^. UserId ==. f ^. FollowAuthorId
where_ $ u ^. UserUsername ==. val uname)
then_ $
val True
]
(else_ $ val False)
where_ $ user ^. UserUsername ==. val username
where_ $ article ^. ArticleSlug ==. val slug
return (article ^. ArticleId, user, narcissticprick (Just username))
case something of
[] -> return Nothing
(articleid, entuser, valfollow):_ -> do
comment <- insertEntity $ Comment body now Nothing (unValue articleid) (entityKey entuser)
return $ Just (comment, entuser, valfollow)
......@@ -183,3 +183,15 @@ data ResponseTags = ResponseTags
} deriving (Generic)
instance ToJSON ResponseTags where
toJSON = genericToJSON (aesonPrefix camelCase)
data ResponseErrorBody = ResponseErrorBody
{ resperrbodyBody :: Text
} deriving (Generic)
instance ToJSON ResponseErrorBody where
toJSON = genericToJSON (aesonPrefix camelCase)
data ResponseError = ResponseError
{ resperrErrors :: ResponseErrorBody
} deriving (Generic)
instance ToJSON ResponseError where
toJSON = genericToJSON (aesonPrefix camelCase)
......@@ -3,11 +3,15 @@ module Util where
import Lib.Prelude
import Crypto.BCrypt
import Data.Aeson
import qualified Data.ByteString.Char8 as BC (pack)
import qualified Data.ByteString.Lazy as BL
import Data.Text (pack, toLower, unpack)
import Servant.Auth.Server
import Text.Regex
import Types
generatePassword :: Text -> IO Text
generatePassword password = do
mpass <-
......@@ -28,3 +32,6 @@ titleDescToSlug title desc appendage =
where
smaller sentence =
toLower (pack (subRegex (mkRegex "[^a-zA-Z0-9_.]") (unpack sentence) "-"))
encodeRespError :: Text -> BL.ByteString
encodeRespError = encode . ResponseError . ResponseErrorBody
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment