nodew/haskell-realworld-example
1
1
Fork 0
mirror of https://github.com/nodew/haskell-realworld-example.git synced 2024-10-05 13:17:32 +03:00
Code Issues Projects Releases Wiki Activity

Add fourmolu support & update config.

Browse Source
This commit is contained in:
Qiao Wang 2023-05-19 07:06:51 +00:00
parent f791b8d7a7
commit 0c89cc9b83
44 changed files with 1274 additions and 1128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.devcontainer/devcontainer.json
View File

@ -8,14 +8,15 @@
"ghcVersion": "9.2.7",
"installHLS": true,
"installStack": true,
"installStackGHCupHook": true
// "globalPackages": ""
"installStackGHCupHook": true,
"globalPackages": "fourmolu"
}
},
"customizations": {
"vscode": {
"extensions": [
"haskell.haskell"
"haskell.haskell",
"streetsidesoftware.code-spell-checker"
]
}
},

4
.vscode/settings.json vendored
View File

@ -21,5 +21,7 @@
"uncurry",
"unfollow",
"varchar"
]
],
"haskell.plugin.fourmolu.config.external": true,
"haskell.formattingProvider": "fourmolu"
}

3
app/Main.hs
View File

@ -1,9 +1,8 @@
module Main where
import RIO
import Conduit
import Conduit.Config
import RIO
main :: IO ()
main = do

16
fourmolu.yaml Normal file
View File

@ -0,0 +1,16 @@
indentation: 4
column-limit: 120
function-arrows: trailing
comma-style: leading
import-export-style: leading
indent-wheres: true
record-brace-space: true
newlines-between-decls: 1
haddock-style: single-line
haddock-style-module: null
let-style: inline
in-style: right-align
single-constraint-parens: always
unicode: never
respectful: true
fixities: []

3
package.yaml
View File

@ -58,6 +58,7 @@ default-extensions:
library:
source-dirs: src
language: GHC2021
executables:
conduit-server-exe:
@ -69,6 +70,7 @@ executables:
- -with-rtsopts=-N
dependencies:
- conduit-server
language: GHC2021
tests:
conduit-server-test:
@ -84,3 +86,4 @@ tests:
- hspec-wai
- QuickCheck
- conduit-server
language: GHC2021

52
src/Conduit.hs
View File

@ -1,35 +1,34 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnicodeSyntax #-}
module Conduit where
import RIO
import Prelude (putStrLn)
import Data.Default
import Conduit.Api
import Conduit.App
import Conduit.Auth
import Conduit.Config
import Conduit.Core.User
import Conduit.Db
import Control.Monad.Extra
import Crypto.JOSE.JWK hiding (Context)
import Data.Default
import GHC.Generics (Generic)
import Servant hiding (runHandler)
import Servant.Server.Experimental.Auth
import Hasql.Pool (acquire)
import Network.Wai (Middleware, Request, requestHeaders)
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.RequestLogger.JSON
import Crypto.JOSE.JWK hiding (Context)
import Hasql.Pool (acquire)
import Conduit.Config
import Conduit.Auth
import Conduit.Api
import Conduit.Core.User
import Conduit.Db
import Conduit.App
import RIO
import Servant hiding (runHandler)
import Servant.Server.Experimental.Auth
import Prelude (putStrLn)
type AuthContext = AuthHandler Request User ': AuthHandler Request (Maybe User) ': '[]
@ -43,6 +42,7 @@ mkApp env =
serverAuthContext :: Context AuthContext
serverAuthContext = handleAuthentication env :. handleOptionalAuthentication env :. EmptyContext
hoistedServer :: ServerT ConduitApi Servant.Handler
hoistedServer = hoistServerWithContext api (Proxy :: Proxy AuthContext) (runHandler env) conduitServer
runConduit :: Config -> IO ()
@ -52,7 +52,8 @@ runConduit cfg = do
result <- autoMigrate pool
whenJust result $ \e -> do
error $ show e
let env = AppEnv
let env =
AppEnv
{ envDbPool = pool
, envJwtKey = jwtKey
}
@ -61,11 +62,12 @@ runConduit cfg = do
runApplication :: Int -> AppEnv -> IO ()
runApplication port env = do
warpLogger <- jsonRequestLogger
let warpSettings = Warp.defaultSettings
& Warp.setPort port
& Warp.setTimeout 60
let warpSettings =
Warp.defaultSettings
& Warp.setPort port
& Warp.setTimeout 60
Warp.runSettings warpSettings $ warpLogger $ mkApp env
jsonRequestLogger :: IO Middleware
jsonRequestLogger =
mkRequestLogger $ def { outputFormat = CustomOutputFormatWithDetails formatAsJSON }
mkRequestLogger $ def {outputFormat = CustomOutputFormatWithDetails formatAsJSON}

47
src/Conduit/Api.hs
View File

@ -1,31 +1,34 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
module Conduit.Api where
import Conduit.Api.Article
import Conduit.Api.Auth
import Conduit.Api.Comment
import Conduit.Api.Profile
import Conduit.Api.Tag
import Conduit.Api.User
import Conduit.App
import RIO
import Servant
import Conduit.App
import Conduit.Api.Auth
import Conduit.Api.User
import Conduit.Api.Profile
import Conduit.Api.Article
import Conduit.Api.Comment
import Conduit.Api.Tag
type ConduitApi = "api" :> ( AuthApi
:<|> UserApi
:<|> ProfileApi
:<|> ArticleApi
:<|> CommentApi
:<|> TagApi
)
type ConduitApi =
"api"
:> ( AuthApi
:<|> UserApi
:<|> ProfileApi
:<|> ArticleApi
:<|> CommentApi
:<|> TagApi
)
conduitServer :: ServerT ConduitApi AppM
conduitServer = authServer
:<|> userServer
:<|> profileServer
:<|> articleServer
:<|> commentServer
:<|> tagServer
conduitServer =
authServer
:<|> userServer
:<|> profileServer
:<|> articleServer
:<|> commentServer
:<|> tagServer

294
src/Conduit/Api/Article.hs
View File

@ -1,30 +1,31 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module Conduit.Api.Article where
import RIO
import Data.Aeson
import Servant
import Data.Time
import Control.Monad.Trans.Maybe
import Conduit.Api.Common
import Conduit.App
import Conduit.Core.User
import Conduit.Core.Article
import Conduit.Core.User
import qualified Conduit.Repository.Article as ArticleRepository
import qualified Conduit.Repository.User as UserRepository
import Conduit.Api.Common
import Conduit.Util
import Control.Monad.Trans.Maybe
import Data.Aeson
import Data.Time
import RIO
import Servant
data NewArticleData = NewArticleData
{ newArticleTitle :: Text
{ newArticleTitle :: Text
, newArticleDescription :: Text
, newArticleBody :: Text
, newArticleTagList :: [Text]
} deriving (Eq, Show, Generic)
, newArticleBody :: Text
, newArticleTagList :: [Text]
}
deriving (Eq, Show, Generic)
instance FromJSON NewArticleData where
parseJSON = genericParseJSON $ toJsonOptions 10
@ -33,27 +34,29 @@ instance ToJSON NewArticleData where
toJSON = genericToJSON $ toJsonOptions 10
data UpdateArticleData = UpdateArticleData
{ updateArticleTitle :: Maybe Text
{ updateArticleTitle :: Maybe Text
, updateArticleDescription :: Maybe Text
, updateArticleBody :: Maybe Text
, updateArticleTagList :: Maybe [Text]
} deriving (Show, Generic)
, updateArticleBody :: Maybe Text
, updateArticleTagList :: Maybe [Text]
}
deriving (Show, Generic)
instance FromJSON UpdateArticleData where
parseJSON = genericParseJSON $ toJsonOptions 13
data ArticleData = ArticleData
{ articleDataSlug :: Text
, articleDataTitle :: Text
, articleDataDescription :: Text
, articleDataBody :: Text
, articleDataTagList :: [Text]
, articleDataCreatedAt :: UTCTime
, articleDataUpdatedAt :: UTCTime
, articleDataFavorited :: Bool
{ articleDataSlug :: Text
, articleDataTitle :: Text
, articleDataDescription :: Text
, articleDataBody :: Text
, articleDataTagList :: [Text]
, articleDataCreatedAt :: UTCTime
, articleDataUpdatedAt :: UTCTime
, articleDataFavorited :: Bool
, articleDataFavoritesCount :: Int64
, articleDataAuthor :: UserProfile
} deriving (Eq, Show, Generic)
, articleDataAuthor :: UserProfile
}
deriving (Eq, Show, Generic)
instance ToJSON ArticleData where
toJSON = genericToJSON $ toJsonOptions 11
@ -62,7 +65,8 @@ instance FromJSON ArticleData where
parseJSON = genericParseJSON $ toJsonOptions 11
newtype BoxedArticle a = BoxedArticle
{ boxedArticle :: a } deriving (Eq, Show, Generic)
{boxedArticle :: a}
deriving (Eq, Show, Generic)
instance ToJSON a => ToJSON (BoxedArticle a) where
toJSON = genericToJSON $ toJsonOptions 5
@ -72,8 +76,9 @@ instance FromJSON a => FromJSON (BoxedArticle a) where
data ArticlesResponse = ArticlesResponse
{ articlesRespArticlesCount :: Int64
, articlesRespArticles :: [ArticleData]
} deriving (Eq, Show, Generic)
, articlesRespArticles :: [ArticleData]
}
deriving (Eq, Show, Generic)
instance ToJSON ArticlesResponse where
toJSON = genericToJSON $ toJsonOptions 12
@ -84,65 +89,67 @@ instance FromJSON ArticlesResponse where
mapArticleToArticleData :: Article -> UserProfile -> Bool -> Int64 -> ArticleData
mapArticleToArticleData article authorProfile favorited favoritedCount =
ArticleData
{ articleDataSlug = getSlug $ articleSlug article
, articleDataTitle = articleTitle article
, articleDataDescription = articleDescription article
, articleDataBody = articleBody article
, articleDataTagList = articleTags article
, articleDataCreatedAt = articleCreatedAt article
, articleDataUpdatedAt = articleUpdatedAt article
, articleDataFavorited = favorited
{ articleDataSlug = getSlug $ articleSlug article
, articleDataTitle = articleTitle article
, articleDataDescription = articleDescription article
, articleDataBody = articleBody article
, articleDataTagList = articleTags article
, articleDataCreatedAt = articleCreatedAt article
, articleDataUpdatedAt = articleUpdatedAt article
, articleDataFavorited = favorited
, articleDataFavoritesCount = favoritedCount
, articleDataAuthor = authorProfile
, articleDataAuthor = authorProfile
}
mapEnrichedArticleToArticleData :: ArticleRepository.EnrichedArticle -> ArticleData
mapEnrichedArticleToArticleData (ArticleRepository.EnrichedArticle article author followingAuthor favorited favoritedCount) =
mapArticleToArticleData article (mapUserToUserProfile author followingAuthor) favorited favoritedCount
type ArticleApi = AuthProtect "Optional"
:> "articles"
:> QueryParam "page" Int64
:> QueryParam "pageSize" Int64
:> QueryParam "author" Text
:> QueryParam "favorited" Text
:> QueryParam "tag" Text
:> Get '[JSON] ArticlesResponse
:<|> AuthProtect "Optional"
:> "articles"
:> Capture "slug" Slug
:> Get '[JSON] (BoxedArticle ArticleData)
:<|> AuthProtect "Required"
:> "articles"
:> ReqBody '[JSON] (BoxedArticle NewArticleData)
:> Post '[JSON] (BoxedArticle ArticleData)
:<|> AuthProtect "Required"
:> "articles"
:> Capture "slug" Slug
:> ReqBody '[JSON] (BoxedArticle UpdateArticleData)
:> Put '[JSON] (BoxedArticle ArticleData)
:<|> AuthProtect "Required"
:> "articles"
:> Capture "slug" Slug
:> Delete '[JSON] NoContent
:<|> AuthProtect "Required"
:> "articles"
:> Capture "slug" Slug
:> "favorite"
:> Post '[JSON] (BoxedArticle ArticleData)
:<|> AuthProtect "Required"
:> "articles"
:> Capture "slug" Slug
:> "favorite"
:> Delete '[JSON] (BoxedArticle ArticleData)
type ArticleApi =
AuthProtect "Optional"
:> "articles"
:> QueryParam "page" Int64
:> QueryParam "pageSize" Int64
:> QueryParam "author" Text
:> QueryParam "favorited" Text
:> QueryParam "tag" Text
:> Get '[JSON] ArticlesResponse
:<|> AuthProtect "Optional"
:> "articles"
:> Capture "slug" Slug
:> Get '[JSON] (BoxedArticle ArticleData)
:<|> AuthProtect "Required"
:> "articles"
:> ReqBody '[JSON] (BoxedArticle NewArticleData)
:> Post '[JSON] (BoxedArticle ArticleData)
:<|> AuthProtect "Required"
:> "articles"
:> Capture "slug" Slug
:> ReqBody '[JSON] (BoxedArticle UpdateArticleData)
:> Put '[JSON] (BoxedArticle ArticleData)
:<|> AuthProtect "Required"
:> "articles"
:> Capture "slug" Slug
:> Delete '[JSON] NoContent
:<|> AuthProtect "Required"
:> "articles"
:> Capture "slug" Slug
:> "favorite"
:> Post '[JSON] (BoxedArticle ArticleData)
:<|> AuthProtect "Required"
:> "articles"
:> Capture "slug" Slug
:> "favorite"
:> Delete '[JSON] (BoxedArticle ArticleData)
getArticlesHandler :: Maybe User
-> Maybe Int64
-> Maybe Int64
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> AppM ArticlesResponse
getArticlesHandler ::
Maybe User ->
Maybe Int64 ->
Maybe Int64 ->
Maybe Text ->
Maybe Text ->
Maybe Text ->
AppM ArticlesResponse
getArticlesHandler mbUser mbPage mbPageSize mbAuthorName mbFavorited mbTag = do
(pagedResults, total) <- do
tagId <- maybe (return Nothing) ArticleRepository.getTagId mbTag
@ -159,40 +166,44 @@ getArticlesHandler mbUser mbPage mbPageSize mbAuthorName mbFavorited mbTag = do
where
isValidParam :: Maybe a -> Maybe b -> Bool
isValidParam (Just _) Nothing = False
isValidParam _ _ = True
isValidParam _ _ = True
withValidFilter :: forall a b c . Maybe a -> Maybe b -> AppM ([c], Int64) -> AppM ([c], Int64)
withValidFilter :: forall a b c. Maybe a -> Maybe b -> AppM ([c], Int64) -> AppM ([c], Int64)
withValidFilter a b m
| isValidParam a b = m
| otherwise = return ([], 0)
| otherwise = return ([], 0)
getArticleBySlugHandler :: Maybe User -> Slug -> AppM (BoxedArticle ArticleData)
getArticleBySlugHandler mbUser slug = do
ArticleRepository.getEnrichedArticleBySlug mbUser slug
>>= maybe (throwIO err404)
(return . BoxedArticle . mapEnrichedArticleToArticleData)
>>= maybe
(throwIO err404)
(return . BoxedArticle . mapEnrichedArticleToArticleData)
getArticleByIdHandler :: Maybe User -> ArticleId -> AppM (BoxedArticle ArticleData)
getArticleByIdHandler mbUser articleId =
ArticleRepository.getEnrichedArticleById mbUser articleId
>>= maybe (throwIO err404)
(return . BoxedArticle . mapEnrichedArticleToArticleData)
>>= maybe
(throwIO err404)
(return . BoxedArticle . mapEnrichedArticleToArticleData)
createNewArticleHandler :: User -> BoxedArticle NewArticleData -> AppM (BoxedArticle ArticleData)
createNewArticleHandler user (BoxedArticle newArticle) = do
currentTime <- liftIO getCurrentTime
slug <- mkSlug title
article <- ArticleRepository.createArticle $ Article
{ articleAuthorId = userId user
, articleId = ArticleId 0
, articleTitle = title
, articleSlug = slug
, articleDescription = description
, articleBody = body
, articleTags = tags
, articleCreatedAt = currentTime
, articleUpdatedAt = currentTime
}
article <-
ArticleRepository.createArticle $
Article
{ articleAuthorId = userId user
, articleId = ArticleId 0
, articleTitle = title
, articleSlug = slug
, articleDescription = description
, articleBody = body
, articleTags = tags
, articleCreatedAt = currentTime
, articleUpdatedAt = currentTime
}
flipMaybe article (throwIO err400) $ \article' ->
return $ BoxedArticle $ mapArticleToArticleData article' (mapUserToUserProfile user False) False 0
where
@ -207,20 +218,20 @@ updateArticleHandler user slug (BoxedArticle updateData) =
where
updateArticle article =
if articleAuthorId article /= userId user
then
throwIO err403
else do
currentTime <- liftIO getCurrentTime
let updatedArticle = article
{ articleTitle = fromMaybe (articleTitle article) (updateArticleTitle updateData)
, articleDescription = fromMaybe (articleDescription article) (updateArticleDescription updateData)
, articleBody = fromMaybe (articleBody article) (updateArticleBody updateData)
, articleTags = fromMaybe (articleTags article) (updateArticleTagList updateData)
, articleUpdatedAt = currentTime
}
ArticleRepository.updateArticle updatedArticle
favoritedCount <- ArticleRepository.getArticleFavoritedCount (articleId article)
return $ BoxedArticle $ mapArticleToArticleData updatedArticle (mapUserToUserProfile user False) False favoritedCount
then throwIO err403
else do
currentTime <- liftIO getCurrentTime
let updatedArticle =
article
{ articleTitle = fromMaybe (articleTitle article) (updateArticleTitle updateData)
, articleDescription = fromMaybe (articleDescription article) (updateArticleDescription updateData)
, articleBody = fromMaybe (articleBody article) (updateArticleBody updateData)
, articleTags = fromMaybe (articleTags article) (updateArticleTagList updateData)
, articleUpdatedAt = currentTime
}
ArticleRepository.updateArticle updatedArticle
favoritedCount <- ArticleRepository.getArticleFavoritedCount (articleId article)
return $ BoxedArticle $ mapArticleToArticleData updatedArticle (mapUserToUserProfile user False) False favoritedCount
deleteArticleHandler :: User -> Slug -> AppM NoContent
deleteArticleHandler user slug =
@ -228,11 +239,10 @@ deleteArticleHandler user slug =
where
deleteArticle article =
if articleAuthorId article /= userId user
then
throwIO err403
else do
ArticleRepository.deleteArticleById (articleId article)
return NoContent
then throwIO err403
else do
ArticleRepository.deleteArticleById (articleId article)
return NoContent
favoriteArticleHandler :: User -> Slug -> AppM (BoxedArticle ArticleData)
favoriteArticleHandler user slug =
@ -240,18 +250,16 @@ favoriteArticleHandler user slug =
where
favoriteArticle article =
if articleAuthorId article == userId user
then
throwIO err403
else do
isFavorited <- ArticleRepository.checkFavorite user (articleId article)
if isFavorited
then
throwIO err400
then throwIO err403
else do
success <- ArticleRepository.addFavorite user (articleId article)
if success then
getArticleByIdHandler (Just user) (articleId article)
else throwIO err400
isFavorited <- ArticleRepository.checkFavorite user (articleId article)
if isFavorited
then throwIO err400
else do
success <- ArticleRepository.addFavorite user (articleId article)
if success
then getArticleByIdHandler (Just user) (articleId article)
else throwIO err400
unFavoriteArticleHandler :: User -> Slug -> AppM (BoxedArticle ArticleData)
unFavoriteArticleHandler user slug =
@ -260,19 +268,19 @@ unFavoriteArticleHandler user slug =
unFavoriteArticle article = do
isFavorited <- ArticleRepository.checkFavorite user (articleId article)
if not isFavorited
then
throwIO err400
else do
success <- ArticleRepository.removeFavorite user (articleId article)
if success then
getArticleByIdHandler (Just user) (articleId article)
else throwIO err400
then throwIO err400
else do
success <- ArticleRepository.removeFavorite user (articleId article)
if success
then getArticleByIdHandler (Just user) (articleId article)
else throwIO err400
articleServer :: ServerT ArticleApi AppM
articleServer = getArticlesHandler
:<|> getArticleBySlugHandler
:<|> createNewArticleHandler
:<|> updateArticleHandler
:<|> deleteArticleHandler
:<|> favoriteArticleHandler
:<|> unFavoriteArticleHandler
articleServer =
getArticlesHandler
:<|> getArticleBySlugHandler
:<|> createNewArticleHandler
:<|> updateArticleHandler
:<|> deleteArticleHandler
:<|> favoriteArticleHandler
:<|> unFavoriteArticleHandler

74
src/Conduit/Api/Auth.hs
View File

@ -1,26 +1,27 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
module Conduit.Api.Auth where
import RIO
import Data.Aeson
import Data.Aeson.Types
import Servant
import Conduit.App
import Conduit.Api.Common
import qualified Conduit.Repository.User as UserRepository
import Conduit.App
import Conduit.Core.Password
import Conduit.Core.User
import Conduit.JWT
import Conduit.Util
import Conduit.Environment
import Conduit.JWT
import qualified Conduit.Repository.User as UserRepository
import Conduit.Util
import Data.Aeson
import Data.Aeson.Types
import RIO
import Servant
data LoginUser = LoginUser
{ loginEmail :: Text
, loginPassword :: Text
} deriving (Show, Generic)
}
deriving (Show, Generic)
instance ToJSON LoginUser where
toJSON = genericToJSON $ toJsonOptions 5
@ -30,9 +31,10 @@ instance FromJSON LoginUser where
data NewUser = NewUser
{ newUserUsername :: Text
, newUserEmail :: Text
, newUserEmail :: Text
, newUserPassword :: Text
} deriving (Show, Generic)
}
deriving (Show, Generic)
instance ToJSON NewUser where
toJSON = genericToJSON $ toJsonOptions 7
@ -42,11 +44,12 @@ instance FromJSON NewUser where
data LoginResponse = LoginResponse
{ loginRespUsername :: Text
, loginRespEmail :: Text
, loginRespToken :: Text
, loginRespBio :: Text
, loginRespImage :: Text
} deriving (Eq, Show, Generic)
, loginRespEmail :: Text
, loginRespToken :: Text
, loginRespBio :: Text
, loginRespImage :: Text
}
deriving (Eq, Show, Generic)
instance ToJSON LoginResponse where
toJSON = genericToJSON $ toJsonOptions 9
@ -55,23 +58,25 @@ instance FromJSON LoginResponse where
parseJSON = genericParseJSON $ toJsonOptions 9
mapUserToLoginResponse :: User -> Text -> LoginResponse
mapUserToLoginResponse user token = LoginResponse
{ loginRespUsername = getUsername $ userName user
, loginRespEmail = getEmailAddress $ userEmail user
, loginRespToken = token
, loginRespBio = userBio user
, loginRespImage = userImage user
}
mapUserToLoginResponse user token =
LoginResponse
{ loginRespUsername = getUsername $ userName user
, loginRespEmail = getEmailAddress $ userEmail user
, loginRespToken = token
, loginRespBio = userBio user
, loginRespImage = userImage user
}
{---------------------------------------------------------------------------------------}
type AuthApi = "users"
:> "login"
:> ReqBody '[JSON] (UserData LoginUser)
:> Post '[JSON] (UserData LoginResponse)
:<|> "users"
:> ReqBody '[JSON] (UserData NewUser)
:> Post '[JSON] (UserData LoginResponse)
type AuthApi =
"users"
:> "login"
:> ReqBody '[JSON] (UserData LoginUser)
:> Post '[JSON] (UserData LoginResponse)
:<|> "users"
:> ReqBody '[JSON] (UserData NewUser)
:> Post '[JSON] (UserData LoginResponse)
loginHandler :: UserData LoginUser -> AppM (UserData LoginResponse)
loginHandler (UserData u) =
@ -93,8 +98,9 @@ genUserResponse user = do
let username = userName user
jwtKey <- getJwtKey'
claims <- liftIO $ mkClaims username
liftIO $ signJwt jwtKey claims
>>= either (\_ -> throwIO err422) (return . mapUserToLoginResponse user)
liftIO $
signJwt jwtKey claims
>>= either (\_ -> throwIO err422) (return . mapUserToLoginResponse user)
authServer :: ServerT AuthApi AppM
authServer = loginHandler :<|> registerHandler

162
src/Conduit/Api/Comment.hs
View File

@ -1,33 +1,33 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeOperators #-}
module Conduit.Api.Comment where
import RIO
import Control.Monad.Trans.Except
import Data.Aeson
import Data.UUID
import Data.Time
import Servant
import Conduit.App
import Conduit.Core.Comment
import Conduit.Core.Article
import Conduit.Core.User
import Conduit.Api.Common
import Conduit.App
import Conduit.Core.Article
import Conduit.Core.Comment
import Conduit.Core.User
import qualified Conduit.Repository.Article as ArticleRepository
import qualified Conduit.Repository.Comment as CommentRepository
import Conduit.Util
import Control.Monad.Trans.Except
import Data.Aeson
import Data.Time
import Data.UUID
import RIO
import Servant
data CommentData = CommentData
{ commentDataId :: UUID
, commentDataBody :: Text
, commentDataCreatedAt :: UTCTime
, commentDataUpdatedAt :: UTCTime
, commentDataAuthor :: UserProfile
} deriving (Eq, Show, Generic)
{ commentDataId :: UUID
, commentDataBody :: Text
, commentDataCreatedAt :: UTCTime
, commentDataUpdatedAt :: UTCTime
, commentDataAuthor :: UserProfile
}
deriving (Eq, Show, Generic)
instance ToJSON CommentData where
toJSON = genericToJSON $ toJsonOptions 11
@ -36,7 +36,8 @@ instance FromJSON CommentData where
parseJSON = genericParseJSON $ toJsonOptions 11
newtype NewCommentData = NewCommentData
{ newCommentBody :: Text } deriving (Generic)
{newCommentBody :: Text}
deriving (Generic)
instance ToJSON NewCommentData where
toJSON = genericToJSON $ toJsonOptions 10
@ -45,7 +46,8 @@ instance FromJSON NewCommentData where
parseJSON = genericParseJSON $ toJsonOptions 10
newtype BoxedComment a = BoxedComment
{ unBoxedComment :: a } deriving (Eq, Show, Generic)
{unBoxedComment :: a}
deriving (Eq, Show, Generic)
instance FromJSON a => FromJSON (BoxedComment a) where
parseJSON = genericParseJSON $ toJsonOptions 7
@ -54,7 +56,8 @@ instance ToJSON a => ToJSON (BoxedComment a) where
toJSON = genericToJSON $ toJsonOptions 7
newtype CommentsResponse = CommentsResponse
{ cmtRespComments :: [CommentData] } deriving (Generic)
{cmtRespComments :: [CommentData]}
deriving (Generic)
instance ToJSON CommentsResponse where
toJSON = genericToJSON $ toJsonOptions 7
@ -62,75 +65,88 @@ instance ToJSON CommentsResponse where
mapEnrichedCommentToCommentData :: (Comment, User, Bool) -> CommentData
mapEnrichedCommentToCommentData (comment, author, followingAuthor) =
CommentData
{ commentDataId = commentUUID comment
, commentDataBody = commentBody comment
{ commentDataId = commentUUID comment
, commentDataBody = commentBody comment
, commentDataCreatedAt = commentCreatedAt comment
, commentDataUpdatedAt = commentUpdatedAt comment
, commentDataAuthor = mapUserToUserProfile author followingAuthor
, commentDataAuthor = mapUserToUserProfile author followingAuthor
}
type CommentApi = "articles"
:> Capture "slug" Slug
:> "comments"
:> (
AuthProtect "Optional"
:> Get '[JSON] CommentsResponse
:<|> AuthProtect "Required"
:> ReqBody '[JSON] (BoxedComment NewCommentData)
:> Post '[JSON] (BoxedComment CommentData)
:<|> AuthProtect "Required"
:> Capture "commentId" UUID
:> Delete '[JSON] NoContent
)
type CommentApi =
"articles"
:> Capture "slug" Slug
:> "comments"
:> ( AuthProtect "Optional"
:> Get '[JSON] CommentsResponse
:<|> AuthProtect "Required"
:> ReqBody '[JSON] (BoxedComment NewCommentData)
:> Post '[JSON] (BoxedComment CommentData)
:<|> AuthProtect "Required"
:> Capture "commentId" UUID
:> Delete '[JSON] NoContent
)
getAllComments :: Slug -> Maybe User -> AppM CommentsResponse
getAllComments slug mbUser =
ArticleRepository.getArticleBySlug slug
>>= maybe (throwIO err404)
(\article -> do
comments <- CommentRepository.getEnrichedCommentsByArticleId mbUser (articleId article)
return $ CommentsResponse $ map mapEnrichedCommentToCommentData comments)
>>= maybe
(throwIO err404)
( \article -> do
comments <- CommentRepository.getEnrichedCommentsByArticleId mbUser (articleId article)
return $ CommentsResponse $ map mapEnrichedCommentToCommentData comments
)
createComment :: Slug
-> User
-> BoxedComment NewCommentData
-> AppM (BoxedComment CommentData)
createComment ::
Slug ->
User ->
BoxedComment NewCommentData ->
AppM (BoxedComment CommentData)
createComment slug user (BoxedComment newComment) =
ArticleRepository.getArticleBySlug slug >>= maybe (throwIO err404) createComment
where
createComment article = do
currentTime <- liftIO getCurrentTime
uuid <- liftIO newUUID
comment <- CommentRepository.addComment $ Comment
{ commentId = CommentId 0
, commentUUID = uuid
, commentBody = newCommentBody newComment
, commentArticleId = articleId article
, commentAuthorId = userId user
, commentCreatedAt = currentTime
, commentUpdatedAt = currentTime
}
comment <-
CommentRepository.addComment $
Comment
{ commentId = CommentId 0
, commentUUID = uuid
, commentBody = newCommentBody newComment
, commentArticleId = articleId article
, commentAuthorId = userId user
, commentCreatedAt = currentTime
, commentUpdatedAt = currentTime
}
flipMaybe comment (throwIO err404) $ \comment' ->
return $ BoxedComment $ mapEnrichedCommentToCommentData (comment', user, False)
deleteComment :: Slug
-> User
-> UUID
-> AppM NoContent
deleteComment ::
Slug ->
User ->
UUID ->
AppM NoContent
deleteComment slug user uuid =
ArticleRepository.getArticleBySlug slug >>= maybe (throwIO err404) (\article -> do
CommentRepository.getCommentByUUID uuid >>= maybe (throwIO err404) (\comment -> do
if (commentAuthorId comment /= userId user) || (commentArticleId comment /= articleId article)
then
throwIO err403
else do
success <- CommentRepository.deleteCommentById (commentId comment)
if success
then return NoContent
else throwIO err400
))
ArticleRepository.getArticleBySlug slug
>>= maybe
(throwIO err404)
( \article -> do
CommentRepository.getCommentByUUID uuid
>>= maybe
(throwIO err404)
( \comment -> do
if (commentAuthorId comment /= userId user) || (commentArticleId comment /= articleId article)
then throwIO err403
else do
success <- CommentRepository.deleteCommentById (commentId comment)
if success
then return NoContent
else throwIO err400
)
)
commentServer :: ServerT CommentApi AppM
commentServer slug = getAllComments slug
:<|> createComment slug
:<|> deleteComment slug
commentServer slug =
getAllComments slug
:<|> createComment slug
:<|> deleteComment slug

34
src/Conduit/Api/Common.hs
View File

@ -1,13 +1,13 @@
{-# LANGUAGE DeriveGeneric #-}
module Conduit.Api.Common where
import RIO
import Data.Aeson
import Conduit.Util
import Conduit.Core.User
import Conduit.Util
import Data.Aeson
import RIO
newtype UserData a = UserData { userData :: a }
newtype UserData a = UserData {userData :: a}
deriving (Eq, Show, Generic)
instance ToJSON a => ToJSON (UserData a) where
@ -18,7 +18,7 @@ instance FromJSON a => FromJSON (UserData a) where
a <- o .: "user"
return (UserData a)
newtype Profile a = Profile { profile :: a }
newtype Profile a = Profile {profile :: a}
deriving (Show, Generic)
instance ToJSON a => ToJSON (Profile a) where
@ -30,11 +30,12 @@ instance FromJSON a => FromJSON (Profile a) where
return (Profile a)
data UserProfile = UserProfile
{ profileUsername :: Text
, profileBio :: Text
, profileImage :: Text
{ profileUsername :: Text
, profileBio :: Text
, profileImage :: Text
, profileFollowing :: Bool
} deriving (Eq, Show, Generic)
}
deriving (Eq, Show, Generic)
instance ToJSON UserProfile where
toJSON = genericToJSON $ toJsonOptions 7
@ -43,9 +44,10 @@ instance FromJSON UserProfile where
parseJSON = genericParseJSON $ toJsonOptions 7
mapUserToUserProfile :: User -> Bool -> UserProfile
mapUserToUserProfile user following = UserProfile
{ profileUsername = getUsername $ userName user
, profileBio = userBio user
, profileImage = userImage user
, profileFollowing = following
}
mapUserToUserProfile user following =
UserProfile
{ profileUsername = getUsername $ userName user
, profileBio = userBio user
, profileImage = userImage user
, profileFollowing = following
}

75
src/Conduit/Api/Profile.hs
View File

@ -1,28 +1,34 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module Conduit.Api.Profile where
import RIO
import Data.Aeson
import Servant
import qualified Data.Text as T
import Data.Maybe
import Conduit.Api.Common
import Conduit.App
import Conduit.Core.User
import Conduit.Api.Common
import qualified Conduit.Repository.User as UserRepository
import Conduit.Util
import Data.Aeson
import Data.Maybe
import qualified Data.Text as T
import RIO
import Servant
type ProfileApi = AuthProtect "Optional"
:> "profiles" :> Capture "username" Text
:> Get '[JSON] (Profile UserProfile)
:<|> AuthProtect "Required"
:> "profiles" :> Capture "username" Text :> "follow"
:> Post '[JSON] (Profile UserProfile)
:<|> AuthProtect "Required"
:> "profiles" :> Capture "username" Text :> "follow"
:> Delete '[JSON] (Profile UserProfile)
type ProfileApi =
AuthProtect "Optional"
:> "profiles"
:> Capture "username" Text
:> Get '[JSON] (Profile UserProfile)
:<|> AuthProtect "Required"
:> "profiles"
:> Capture "username" Text
:> "follow"
:> Post '[JSON] (Profile UserProfile)
:<|> AuthProtect "Required"
:> "profiles"
:> Capture "username" Text
:> "follow"
:> Delete '[JSON] (Profile UserProfile)
getProfileHandler :: Maybe User -> Text -> AppM (Profile UserProfile)
getProfileHandler mbUser targetUsername
@ -32,10 +38,12 @@ getProfileHandler mbUser targetUsername
return $ Profile $ mapUserToUserProfile user False
| otherwise =
UserRepository.getUserByName (Username targetUsername)
>>= maybe (throwIO err404)
(\targetUser -> do
following <- flipMaybe mbUser (return False) $ \user -> UserRepository.checkFollowship user (userId targetUser)
return $ Profile $ mapUserToUserProfile targetUser following)
>>= maybe
(throwIO err404)
( \targetUser -> do
following <- flipMaybe mbUser (return False) $ \user -> UserRepository.checkFollowship user (userId targetUser)
return $ Profile $ mapUserToUserProfile targetUser following
)
followUserHandler :: User -> Text -> AppM (Profile UserProfile)
followUserHandler user targetUsername
@ -43,10 +51,12 @@ followUserHandler user targetUsername
| (getUsername . userName) user == targetUsername = throwIO err403
| otherwise = do
UserRepository.getUserByName (Username targetUsername)
>>= maybe (throwIO err404)
(\targetUser -> do
_ <- UserRepository.followUser user (userId targetUser)
return $ Profile $ mapUserToUserProfile targetUser True)
>>= maybe
(throwIO err404)
( \targetUser -> do
_ <- UserRepository.followUser user (userId targetUser)
return $ Profile $ mapUserToUserProfile targetUser True
)
unFollowUserHandler :: User -> Text -> AppM (Profile UserProfile)
unFollowUserHandler user targetUsername
@ -54,12 +64,15 @@ unFollowUserHandler user targetUsername
| (getUsername . userName) user == targetUsername = throwIO err403
| otherwise =
UserRepository.getUserByName (Username targetUsername)
>>= maybe (throwIO err404)
(\targetUser -> do
_ <- UserRepository.unfollowUser user (userId targetUser)
return $ Profile $ mapUserToUserProfile targetUser False)
>>= maybe
(throwIO err404)
( \targetUser -> do
_ <- UserRepository.unfollowUser user (userId targetUser)
return $ Profile $ mapUserToUserProfile targetUser False
)
profileServer :: ServerT ProfileApi AppM
profileServer = getProfileHandler
:<|> followUserHandler
:<|> unFollowUserHandler
profileServer =
getProfileHandler
:<|> followUserHandler
:<|> unFollowUserHandler

17
src/Conduit/Api/Tag.hs
View File

@ -1,22 +1,21 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeOperators #-}
module Conduit.Api.Tag where
import RIO
import Rel8
import Conduit.App
import Conduit.Db
import Data.Aeson
import Hasql.Transaction (statement)
import RIO
import Rel8
import Servant
import Conduit.Db
import Conduit.App
newtype TagsResponse = TagsResponse
{ tags :: [Text] } deriving (Generic)
{tags :: [Text]}
deriving (Generic)
instance ToJSON TagsResponse where
toJSON (TagsResponse a) = object ["tags" .= a]

78
src/Conduit/Api/User.hs
View File

@ -1,25 +1,26 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Conduit.Api.User where
{-# LANGUAGE TypeOperators #-}
import RIO
import Data.Aeson
import Servant
module Conduit.Api.User where
import Conduit.Api.Common
import Conduit.App
import Conduit.Core.User
import Conduit.Core.Password
import Conduit.Core.User
import qualified Conduit.Repository.User as UserRepository
import Conduit.Util
import Data.Aeson
import RIO
import Servant
data UserResponse = UserResponse
{ urUsername :: Text
, urEmail :: Text
, urBio :: Text
, urImage :: Text
} deriving (Show, Eq, Generic)
, urEmail :: Text
, urBio :: Text
, urImage :: Text
}
deriving (Show, Eq, Generic)
instance ToJSON UserResponse where
toJSON = genericToJSON $ toJsonOptions 2
@ -29,30 +30,33 @@ instance FromJSON UserResponse where
data UpdateUserRequest = UpdateUserRequest
{ uurUsername :: Maybe Text
, uurEmail :: Maybe Text
, uurEmail :: Maybe Text
, uurPassword :: Maybe Text
, uurBio :: Maybe Text
, uurImage :: Maybe Text
} deriving (Show, Generic)
, uurBio :: Maybe Text
, uurImage :: Maybe Text
}
deriving (Show, Generic)
instance FromJSON UpdateUserRequest where
parseJSON = genericParseJSON $ toJsonOptions 3
mapUserToUserResponse :: User -> UserResponse
mapUserToUserResponse user = UserResponse
{ urUsername = getUsername $ userName user
, urEmail = getEmailAddress $ userEmail user
, urBio = userBio user
, urImage = userImage user
}
mapUserToUserResponse user =
UserResponse
{ urUsername = getUsername $ userName user
, urEmail = getEmailAddress $ userEmail user
, urBio = userBio user
, urImage = userImage user
}
type UserApi = AuthProtect "Required"
:> "user"
:> Get '[JSON] (UserData UserResponse)
:<|> AuthProtect "Required"
:> "user"
:> ReqBody '[JSON] (UserData UpdateUserRequest)
:> Put '[JSON] (UserData UserResponse)
type UserApi =
AuthProtect "Required"
:> "user"
:> Get '[JSON] (UserData UserResponse)
:<|> AuthProtect "Required"
:> "user"
:> ReqBody '[JSON] (UserData UpdateUserRequest)
:> Put '[JSON] (UserData UserResponse)
getUserHandler :: User -> AppM (UserData UserResponse)
getUserHandler = return . UserData . mapUserToUserResponse
@ -60,22 +64,22 @@ getUserHandler = return . UserData . mapUserToUserResponse
updateUserHandler :: User -> UserData UpdateUserRequest -> AppM (UserData UserResponse)
updateUserHandler user (UserData user') = do
succeed <- UserRepository.updateUser updatedUser newPassword
if succeed then
return $ UserData $ mapUserToUserResponse updatedUser
else
throwIO err400
if succeed
then return $ UserData $ mapUserToUserResponse updatedUser
else throwIO err400
where
newName = maybe (userName user) Username (uurUsername user')
newEmail = maybe (userEmail user) EmailAddress (uurUsername user')
newPassword = Password <$> uurPassword user'
newBio = fromMaybe (userBio user) (uurBio user')
newImage = fromMaybe (userImage user) (uurImage user')
updatedUser = user
{ userName = newName
, userEmail = newEmail
, userBio = newBio
, userImage = newImage
}
updatedUser =
user
{ userName = newName
, userEmail = newEmail
, userBio = newBio
, userImage = newImage
}
userServer :: ServerT UserApi AppM
userServer = getUserHandler :<|> updateUserHandler

16
src/Conduit/App.hs
View File

@ -1,16 +1,16 @@
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
module Conduit.App where
import RIO
import Hasql.Pool (Pool)
import Crypto.JOSE.JWK ( JWK )
import Control.Monad.Trans.Except ( ExceptT(ExceptT) )
import qualified Servant
import Conduit.Environment
import Control.Monad.Trans.Except (ExceptT (ExceptT))
import Crypto.JOSE.JWK (JWK)
import Hasql.Pool (Pool)
import RIO
import qualified Servant
data AppEnv = AppEnv
{ envDbPool :: Pool
@ -19,7 +19,7 @@ data AppEnv = AppEnv
type AppM = RIO AppEnv
runHandler ∷ AppEnv → AppM a → Servant.Handler a
runHandler :: AppEnv -> AppM a -> Servant.Handler a
runHandler env app = Servant.Handler $ ExceptT $ try $ runRIO env app
instance HasDbPool AppEnv where

63
src/Conduit/Auth.hs
View File

@ -1,53 +1,52 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Conduit.Auth where
import RIO
import RIO.ByteString as B (stripPrefix)
import Conduit.App (AppEnv (envJwtKey))
import Conduit.Core.User (User (..), Username (..))
import Conduit.JWT (getSubject, verifyJwt)
import Conduit.Repository.User (getUserByName)
import Conduit.Util (hoistMaybe)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Crypto.JOSE.JWK (JWK)
import Data.Either.Extra (eitherToMaybe)
import qualified Data.Text as T
import Data.Text qualified as T
import Network.Wai (Request, requestHeaders)
import RIO
import RIO.ByteString as B (stripPrefix)
import Servant (AuthProtect, err401, errBody, throwError)
import Servant.Server.Experimental.Auth
( AuthHandler,
mkAuthHandler,
)
import Conduit.App (AppEnv (envJwtKey))
import Conduit.Core.User (User (..), Username (..))
import Conduit.Repository.User (getUserByName)
import Conduit.JWT (getSubject, verifyJwt)
import Conduit.Util ( hoistMaybe )
import Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)
handleOptionalAuthentication :: AppEnv -> AuthHandler Request (Maybe User)
handleOptionalAuthentication env =
let handler req = liftIO $ getUserFromJwtToken env req
in mkAuthHandler handler
let handler req = liftIO $ getUserFromJwtToken env req
in mkAuthHandler handler
handleAuthentication :: AppEnv -> AuthHandler Request User
handleAuthentication env =
let handler req = do
user <- liftIO $ getUserFromJwtToken env req
case user of
Just user' -> return user'
_ -> throwError $ err401 { errBody = "Invalid JWT Token" }
in mkAuthHandler handler
let handler req = do
user <- liftIO $ getUserFromJwtToken env req
case user of
Just user' -> return user'
_ -> throwError $ err401 {errBody = "Invalid JWT Token"}
in mkAuthHandler handler
getUserFromJwtToken :: AppEnv -> Request -> IO (Maybe User)
getUserFromJwtToken env req = runMaybeT $ do
token <- hoistMaybe $ lookup "Authorization" (requestHeaders req)
username <- decodeToken (envJwtKey env) token
MaybeT $ liftIO $ runRIO env $ getUserByName username
getUserFromJwtToken env req = runMaybeT $
do
token <- hoistMaybe $ lookup "Authorization" (requestHeaders req)
username <- decodeToken (envJwtKey env) token
MaybeT $ liftIO $ runRIO env $ getUserByName username
decodeToken :: JWK -> ByteString -> MaybeT IO Username
decodeToken jwk authToken = do
token <- hoistMaybe $ B.stripPrefix "Token " authToken
claimSet <- MaybeT $ eitherToMaybe <$> verifyJwt jwk token
subject <- hoistMaybe $ getSubject claimSet
if T.length subject > 0
then return $ Username subject
else hoistMaybe Nothing
token <-
hoistMaybe $
B.stripPrefix "Token " authToken <|> B.stripPrefix "Bearer " authToken
claimSet <- MaybeT $ eitherToMaybe <$> verifyJwt jwk token
subject <- hoistMaybe $ getSubject claimSet
if T.length subject > 0
then return $ Username subject
else hoistMaybe Nothing

31
src/Conduit/Config.hs
View File

@ -2,17 +2,18 @@
module Conduit.Config where
import RIO
import Data.Char (toLower)
import System.Environment ( getEnv )
import Conduit.Util (exitWithErrorMessage)
import Data.Char (toLower)
import RIO
import System.Environment (getEnv)
data Config = Config
{ cfgPort :: Int
, cfgJwk :: Text
, cfgConnectString :: ByteString
, cfgPoolSize :: Int
} deriving (Generic, Show)
}
deriving (Generic, Show)
loadConfigFromEnv :: IO Config
loadConfigFromEnv = do
@ -21,16 +22,18 @@ loadConfigFromEnv = do
connectString <- getEnv' "" "POSTGRES_CONNECT_STRING"
poolSize <- getEnv' "1" "POSTGRES_POOL_SIZE"
if null jwk then
exitWithErrorMessage "Environment variable JWK_STRING is missing"
else if null connectString then
exitWithErrorMessage "Environment variable POSTGRES_CONNECT_STRING is missing"
else
return $ Config
(readInt 8080 port)
(fromString jwk)
(fromString connectString)
(readInt 1 poolSize)
if null jwk
then exitWithErrorMessage "Environment variable JWK_STRING is missing"
else
if null connectString
then exitWithErrorMessage "Environment variable POSTGRES_CONNECT_STRING is missing"
else
return $
Config
(readInt 8080 port)
(fromString jwk)
(fromString connectString)
(readInt 1 poolSize)
readInt :: Int -> String -> Int
readInt optional value = fromMaybe optional $ readMaybe value

36
src/Conduit/Core/Article.hs
View File

@ -1,37 +1,37 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Conduit.Core.Article where
import Conduit.Core.User
import Crypto.Hash (SHA256 (SHA256), hashWith)
import Crypto.Random (MonadRandom (getRandomBytes))
import Data.Aeson
import qualified Data.Text as T
import Data.Time
import RIO
import Rel8
import Data.Aeson
import Data.Time
import qualified Data.Text as T
import Servant
import Crypto.Random ( MonadRandom(getRandomBytes) )
import Crypto.Hash ( hashWith, SHA256(SHA256) )
import Conduit.Core.User
data Article = Article
{ articleId :: ArticleId
, articleAuthorId :: UserId
, articleTitle :: Text
, articleSlug :: Slug
{ articleId :: ArticleId
, articleAuthorId :: UserId
, articleTitle :: Text
, articleSlug :: Slug
, articleDescription :: Text
, articleBody :: Text
, articleTags :: [Text]
, articleCreatedAt :: UTCTime
, articleUpdatedAt :: UTCTime
, articleBody :: Text
, articleTags :: [Text]
, articleCreatedAt :: UTCTime
, articleUpdatedAt :: UTCTime
}
newtype ArticleId = ArticleId { getArticleId :: Int64 }
newtype ArticleId = ArticleId {getArticleId :: Int64}
deriving newtype (Eq, Show, Read, FromJSON, ToJSON, DBEq, DBType)
newtype Slug = Slug { getSlug :: Text }
newtype Slug = Slug {getSlug :: Text}
deriving newtype (Eq, Show, Read, FromJSON, ToJSON, FromHttpApiData, DBEq, DBType)
newtype TagId = TagId { getTagId :: Int64 }
newtype TagId = TagId {getTagId :: Int64}
deriving newtype (Eq, Show, Read, FromJSON, ToJSON, DBEq, DBType)
mkSlug :: MonadIO m => Text -> m Slug

26
src/Conduit/Core/Comment.hs
View File

@ -1,25 +1,25 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Conduit.Core.Comment where
import RIO
import Rel8
import Conduit.Core.Article
import Conduit.Core.User
import Data.Aeson
import Data.Time
import Data.UUID
import Conduit.Core.User
import Conduit.Core.Article
import RIO
import Rel8
data Comment = Comment
{ commentId :: CommentId
, commentUUID :: UUID
, commentBody :: Text
, commentArticleId :: ArticleId
, commentAuthorId :: UserId
, commentCreatedAt :: UTCTime
, commentUpdatedAt :: UTCTime
{ commentId :: CommentId
, commentUUID :: UUID
, commentBody :: Text
, commentArticleId :: ArticleId
, commentAuthorId :: UserId
, commentCreatedAt :: UTCTime
, commentUpdatedAt :: UTCTime
}
newtype CommentId = CommentId { getCommentId :: Int64 }
newtype CommentId = CommentId {getCommentId :: Int64}
deriving newtype (Eq, Show, Read, FromJSON, ToJSON, DBEq, DBType)

26
src/Conduit/Core/Password.hs
View File

@ -1,23 +1,24 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Conduit.Core.Password where
import RIO
import Rel8 ( DBEq, DBType )
import Data.Aeson ( FromJSON, ToJSON )
import Crypto.Random ( MonadRandom(getRandomBytes) )
import Crypto.Hash ( hashWith, SHA256(SHA256) )
import Conduit.Util (fromBytesToText, fromTextToBytes)
import Crypto.Hash (SHA256 (SHA256), hashWith)
import Crypto.KDF.BCrypt as Bcrypt (bcrypt, validatePassword)
import qualified Data.Text as T
import Crypto.Random (MonadRandom (getRandomBytes))
import Data.Aeson (FromJSON, ToJSON)
import Data.ByteArray (Bytes, convert)
import Conduit.Util (fromTextToBytes, fromBytesToText)
import qualified Data.Text as T
import RIO
import Rel8 (DBEq, DBType)
newtype Salt = Salt Bytes
newtype HashedPassword = HashedPassword { getHashedPasswd :: Text }
newtype HashedPassword = HashedPassword {getHashedPasswd :: Text}
deriving newtype (Eq, Show, Read, DBEq, DBType)
newtype Password = Password { getPassword :: Text }
newtype Password = Password {getPassword :: Text}
deriving newtype (Eq, Show, Read, FromJSON, ToJSON, DBEq, DBType)
unsafePassword :: Text -> Password
@ -25,8 +26,9 @@ unsafePassword = Password
mkPassword :: Text -> Maybe Password
mkPassword rawText =
if T.length rawText <= 6 then Nothing
else Just $ Password rawText
if T.length rawText <= 6
then Nothing
else Just $ Password rawText
newSalt :: MonadIO m => m Salt
newSalt = liftIO $ Salt <$> getRandomBytes 16
@ -34,7 +36,7 @@ newSalt = liftIO $ Salt <$> getRandomBytes 16
hashPasswordWithSalt :: Password -> Salt -> HashedPassword
hashPasswordWithSalt (Password password) (Salt salt) =
let hash = Bcrypt.bcrypt 10 salt (fromTextToBytes password)
in HashedPassword $ fromBytesToText hash
in HashedPassword $ fromBytesToText hash
hashPassword :: MonadIO m => Password -> m HashedPassword
hashPassword password = hashPasswordWithSalt password <$> newSalt

41
src/Conduit/Core/User.hs
View File

@ -1,37 +1,40 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Conduit.Core.User where
module Conduit.Core.User where
import RIO
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Text as T
import Rel8 ( DBType, DBEq )
import Data.Aeson ( FromJSON, ToJSON )
import Servant.Server.Experimental.Auth
import RIO
import Rel8 (DBEq, DBType)
import Servant
import Servant.Server.Experimental.Auth
data User = User
{ userId :: UserId
, userName :: Username
, userEmail :: EmailAddress
, userBio :: Text
, userImage :: Text
} deriving (Eq, Show, Read, Generic)
data User = User
{ userId :: UserId
, userName :: Username
, userEmail :: EmailAddress
, userBio :: Text
, userImage :: Text
}
deriving (Eq, Show, Read, Generic)
newtype UserId = UserId { getUserId :: Int64 }
newtype UserId = UserId {getUserId :: Int64}
deriving newtype (Eq, Show, Read, FromJSON, ToJSON, DBEq, DBType)
newtype Username = Username { getUsername :: Text }
newtype Username = Username {getUsername :: Text}
deriving newtype (Eq, Show, Read, FromJSON, ToJSON, DBEq, DBType)
newtype EmailAddress = EmailAddress { getEmailAddress :: Text }
newtype EmailAddress = EmailAddress {getEmailAddress :: Text}
deriving newtype (Eq, Show, Read, FromJSON, ToJSON, DBEq, DBType)
instance ToJSON User
instance FromJSON User
type instance AuthServerData (AuthProtect "Required") = User
type instance AuthServerData (AuthProtect "Optional") = (Maybe User)
type instance AuthServerData (AuthProtect "Optional") = (Maybe User)

12
src/Conduit/Db.hs
View File

@ -1,10 +1,10 @@
module Conduit.Db
( module Conduit.Db.Migration
, module Conduit.Db.Schema
, module Conduit.Db.Transaction
) where
import Conduit.Db.Schema
( module Conduit.Db.Migration
, module Conduit.Db.Schema
, module Conduit.Db.Transaction
)
where
import Conduit.Db.Migration
import Conduit.Db.Schema
import Conduit.Db.Transaction

31
src/Conduit/Db/Migration.hs
View File

@ -1,14 +1,14 @@
{-# LANGUAGE TemplateHaskell #-}
module Conduit.Db.Migration where
import RIO
import Conduit.Db.Transaction
import Data.FileEmbed
import Hasql.Migration
import Hasql.Migration.Util
import Hasql.Transaction
import Hasql.Pool
import Data.FileEmbed
import Conduit.Db.Transaction
import Hasql.Transaction
import RIO
scripts :: [(FilePath, ByteString)]
scripts = $(embedDir "sql")
@ -22,21 +22,22 @@ autoMigrate pool = do
runTransactionWithPool pool $ runMigrations migrationCommands
runMigrations :: [MigrationCommand] -> Transaction (Maybe MigrationError)
runMigrations [] = pure Nothing
runMigrations (x:xs) = do
runMigrations [] = pure Nothing
runMigrations (x : xs) = do
err <- runMigration x
case err of
Nothing -> runMigrations xs
Just _ -> return err
Just _ -> return err
initializeMigrationSchema :: Transaction ()
initializeMigrationSchema = do
exist <- existsTable "schema_migrations"
unless exist $ do
sql $ mconcat
[ "create table if not exists schema_migrations "
, "( filename varchar(512) not null"
, ", checksum varchar(32) not null"
, ", executed_at timestamp without time zone not null default now() "
, ");"
]
sql $
mconcat
[ "create table if not exists schema_migrations "
, "( filename varchar(512) not null"
, ", checksum varchar(32) not null"
, ", executed_at timestamp without time zone not null default now() "
, ");"
]

5
src/Conduit/Db/Schema.hs
View File

@ -1,6 +1,7 @@
module Conduit.Db.Schema
( module Schema
) where
( module Schema
)
where
import Conduit.Db.Schema.Article as Schema
import Conduit.Db.Schema.ArticleTag as Schema

153
src/Conduit/Db/Schema/Article.hs
View File

@ -1,28 +1,28 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Conduit.Db.Schema.Article where
import Conduit.Core.Article
import Conduit.Core.User
import Data.Time
import RIO
import Rel8
import Rel8.Expr.Time
import Data.Time
import Conduit.Core.User
import Conduit.Core.Article
data ArticleEntity f = ArticleEntity
{ entityArticleId :: Column f ArticleId
, entityArticleAuthorId :: Column f UserId
, entityArticleTitle :: Column f Text
, entityArticleSlug :: Column f Slug
{ entityArticleId :: Column f ArticleId
, entityArticleAuthorId :: Column f UserId
, entityArticleTitle :: Column f Text
, entityArticleSlug :: Column f Slug
, entityArticleDescription :: Column f Text
, entityArticleBody :: Column f Text
, entityArticleCreatedAt :: Column f UTCTime
, entityArticleUpdatedAt :: Column f UTCTime
, entityArticleBody :: Column f Text
, entityArticleCreatedAt :: Column f UTCTime
, entityArticleUpdatedAt :: Column f UTCTime
}
deriving stock (Generic)
deriving anyclass (Rel8able)
@ -30,65 +30,73 @@ data ArticleEntity f = ArticleEntity
deriving stock instance f ~ Result => Show (ArticleEntity f)
articleSchema :: TableSchema (ArticleEntity Name)
articleSchema = TableSchema
{ name = "articles"
, schema = Nothing
, columns = ArticleEntity
{ entityArticleId = "article_id"
, entityArticleAuthorId = "article_user_id"
, entityArticleTitle = "article_title"
, entityArticleSlug = "article_slug"
, entityArticleDescription = "article_description"
, entityArticleBody = "article_body"
, entityArticleCreatedAt = "article_createdat"
, entityArticleUpdatedAt = "article_updatedat"
articleSchema =
TableSchema
{ name = "articles"
, schema = Nothing
, columns =
ArticleEntity
{ entityArticleId = "article_id"
, entityArticleAuthorId = "article_user_id"
, entityArticleTitle = "article_title"
, entityArticleSlug = "article_slug"
, entityArticleDescription = "article_description"
, entityArticleBody = "article_body"
, entityArticleCreatedAt = "article_createdat"
, entityArticleUpdatedAt = "article_updatedat"
}
}
}
mapArticleEntityToArticle :: ArticleEntity Result -> Article
mapArticleEntityToArticle entity = Article
{ articleId = entityArticleId entity
, articleAuthorId = entityArticleAuthorId entity
, articleTitle = entityArticleTitle entity
, articleSlug = entityArticleSlug entity
, articleDescription = entityArticleDescription entity
, articleBody = entityArticleBody entity
, articleTags = []
, articleCreatedAt = entityArticleCreatedAt entity
, articleUpdatedAt = entityArticleUpdatedAt entity
}
mapArticleEntityToArticle entity =
Article
{ articleId = entityArticleId entity
, articleAuthorId = entityArticleAuthorId entity
, articleTitle = entityArticleTitle entity
, articleSlug = entityArticleSlug entity
, articleDescription = entityArticleDescription entity
, articleBody = entityArticleBody entity
, articleTags = []
, articleCreatedAt = entityArticleCreatedAt entity
, articleUpdatedAt = entityArticleUpdatedAt entity
}
insertArticleStmt :: Article -> Insert [ArticleId]
insertArticleStmt article = Insert
{ into = articleSchema
, rows = values [ ArticleEntity
{ entityArticleId = unsafeCastExpr $ nextval "articles_article_id_seq"
, entityArticleAuthorId = lit (articleAuthorId article)
, entityArticleTitle = lit (articleTitle article)
, entityArticleSlug = lit (articleSlug article)
, entityArticleDescription = lit (articleDescription article)
, entityArticleBody = lit (articleBody article)
, entityArticleCreatedAt = now
, entityArticleUpdatedAt = now
}
]
, onConflict = Abort
, returning = Projection entityArticleId
}
insertArticleStmt article =
Insert
{ into = articleSchema
, rows =
values
[ ArticleEntity
{ entityArticleId = unsafeCastExpr $ nextval "articles_article_id_seq"
, entityArticleAuthorId = lit (articleAuthorId article)
, entityArticleTitle = lit (articleTitle article)
, entityArticleSlug = lit (articleSlug article)
, entityArticleDescription = lit (articleDescription article)
, entityArticleBody = lit (articleBody article)
, entityArticleCreatedAt = now
, entityArticleUpdatedAt = now
}
]
, onConflict = Abort
, returning = Projection entityArticleId
}
updateArticleStmt :: Article -> Update Int64
updateArticleStmt article = Update
{ target = articleSchema
, from = pure ()
, updateWhere = \_ row -> entityArticleId row ==. lit (articleId article)
, set = \_ row -> row
{ entityArticleTitle = lit (articleTitle article)
, entityArticleDescription = lit (articleDescription article)
, entityArticleBody = lit (articleBody article)
, entityArticleUpdatedAt = now
updateArticleStmt article =
Update
{ target = articleSchema
, from = pure ()
, updateWhere = \_ row -> entityArticleId row ==. lit (articleId article)
, set = \_ row ->
row
{ entityArticleTitle = lit (articleTitle article)
, entityArticleDescription = lit (articleDescription article)
, entityArticleBody = lit (articleBody article)
, entityArticleUpdatedAt = now
}
, returning = NumberOfRowsAffected
}
, returning = NumberOfRowsAffected
}
getArticleEntityByIdStmt :: Expr ArticleId -> Query (ArticleEntity Expr)
getArticleEntityByIdStmt id = do
@ -103,9 +111,10 @@ getArticleEntityBySlugStmt slug = do
return article
deleteArticleByIdStmt :: ArticleId -> Delete Int64
deleteArticleByIdStmt articleId' = Delete
{ from = articleSchema
, using = pure ()
, deleteWhere = \_ row -> entityArticleId row ==. lit articleId'
, returning = NumberOfRowsAffected
}
deleteArticleByIdStmt articleId' =
Delete
{ from = articleSchema
, using = pure ()
, deleteWhere = \_ row -> entityArticleId row ==. lit articleId'
, returning = NumberOfRowsAffected
}

70
src/Conduit/Db/Schema/ArticleTag.hs
View File

@ -1,19 +1,19 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Conduit.Db.Schema.ArticleTag where
import Conduit.Core.Article
import RIO
import Rel8
import Conduit.Core.Article
data ArticleTagEntity f = ArticleTagEntity
{ tgdArticleId :: Column f ArticleId
, tgdTagId :: Column f TagId
, tgdTagId :: Column f TagId
}
deriving stock (Generic)
deriving anyclass (Rel8able)
@ -21,23 +21,25 @@ data ArticleTagEntity f = ArticleTagEntity
deriving stock instance f ~ Result => Show (ArticleTagEntity f)
articleTagSchema :: TableSchema (ArticleTagEntity Name)
articleTagSchema = TableSchema
{ name = "tagged"
, schema = Nothing
, columns = ArticleTagEntity
{ tgdArticleId = "tgd_article_id"
, tgdTagId = "tgd_tag_id"
articleTagSchema =
TableSchema
{ name = "tagged"
, schema = Nothing
, columns =
ArticleTagEntity
{ tgdArticleId = "tgd_article_id"
, tgdTagId = "tgd_tag_id"
}
}
}
insertArticleTagsStmt :: ArticleId -> [TagId] -> Insert Int64
insertArticleTagsStmt articleId tagIds = Insert
{ into = articleTagSchema
, rows = values $ map (ArticleTagEntity (lit articleId) . lit) tagIds
, onConflict = DoNothing
, returning = NumberOfRowsAffected
}
insertArticleTagsStmt articleId tagIds =
Insert
{ into = articleTagSchema
, rows = values $ map (ArticleTagEntity (lit articleId) . lit) tagIds
, onConflict = DoNothing
, returning = NumberOfRowsAffected
}
getAllArticleTagsStmt :: Expr ArticleId -> Query (Expr TagId)
getAllArticleTagsStmt articleId = do
@ -46,17 +48,19 @@ getAllArticleTagsStmt articleId = do
return $ tgdTagId articleTag
deleteAllArticleTagsStmt :: ArticleId -> Delete Int64
deleteAllArticleTagsStmt articleId' = Delete
{ from = articleTagSchema
, using = pure()
, deleteWhere = \_ row -> tgdArticleId row ==. lit articleId'
, returning = NumberOfRowsAffected
}
deleteAllArticleTagsStmt articleId' =
Delete
{ from = articleTagSchema
, using = pure ()
, deleteWhere = \_ row -> tgdArticleId row ==. lit articleId'
, returning = NumberOfRowsAffected
}
deleteArticleTagStmt :: ArticleId -> TagId -> Delete Int64
deleteArticleTagStmt articleId tagId = Delete
{ from = articleTagSchema
, using = pure ()
, deleteWhere = \_ row -> tgdArticleId row ==. lit articleId &&. tgdTagId row ==. lit tagId
, returning = NumberOfRowsAffected
}
deleteArticleTagStmt articleId tagId =
Delete
{ from = articleTagSchema
, using = pure ()
, deleteWhere = \_ row -> tgdArticleId row ==. lit articleId &&. tgdTagId row ==. lit tagId
, returning = NumberOfRowsAffected
}

133
src/Conduit/Db/Schema/Comment.hs
View File

@ -1,27 +1,27 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Conduit.Db.Schema.Comment where
import Conduit.Core.Article
import Conduit.Core.Comment
import Conduit.Core.User
import Data.Time
import Data.UUID
import RIO
import Rel8
import Rel8.Expr.Time
import Data.Time
import Data.UUID
import Conduit.Core.User
import Conduit.Core.Article
import Conduit.Core.Comment
data CommentEntity f = CommentEntity
{ entityCommentId :: Column f CommentId
, entityCommentUUID :: Column f UUID
, entityCommentBody :: Column f Text
{ entityCommentId :: Column f CommentId
, entityCommentUUID :: Column f UUID
, entityCommentBody :: Column f Text
, entityCommentArticleId :: Column f ArticleId
, entityCommentAuthorId :: Column f UserId
, entityCommentAuthorId :: Column f UserId
, entityCommentCreatedAt :: Column f UTCTime
, entityCommentUpdatedAt :: Column f UTCTime
}
@ -31,30 +31,33 @@ data CommentEntity f = CommentEntity
deriving stock instance f ~ Result => Show (CommentEntity f)
commentSchema :: TableSchema (CommentEntity Name)
commentSchema = TableSchema
{ name = "comments"
, schema = Nothing
, columns = CommentEntity
{ entityCommentId = "comment_id"
, entityCommentUUID = "comment_uuid"
, entityCommentBody = "comment_body"
, entityCommentArticleId = "comment_article_id"
, entityCommentAuthorId = "comment_user_id"
, entityCommentCreatedAt = "comment_createdat"
, entityCommentUpdatedAt = "comment_updatedat"
commentSchema =
TableSchema
{ name = "comments"
, schema = Nothing
, columns =
CommentEntity
{ entityCommentId = "comment_id"
, entityCommentUUID = "comment_uuid"
, entityCommentBody = "comment_body"
, entityCommentArticleId = "comment_article_id"
, entityCommentAuthorId = "comment_user_id"
, entityCommentCreatedAt = "comment_createdat"
, entityCommentUpdatedAt = "comment_updatedat"
}
}
}
mapCommentEntityToComment :: CommentEntity Result -> Comment
mapCommentEntityToComment entity = Comment
{ commentId = entityCommentId entity
, commentUUID = entityCommentUUID entity
, commentBody = entityCommentBody entity
, commentArticleId = entityCommentArticleId entity
, commentAuthorId = entityCommentAuthorId entity
, commentCreatedAt = entityCommentCreatedAt entity
, commentUpdatedAt = entityCommentUpdatedAt entity
}
mapCommentEntityToComment entity =
Comment
{ commentId = entityCommentId entity
, commentUUID = entityCommentUUID entity
, commentBody = entityCommentBody entity
, commentArticleId = entityCommentArticleId entity
, commentAuthorId = entityCommentAuthorId entity
, commentCreatedAt = entityCommentCreatedAt entity
, commentUpdatedAt = entityCommentUpdatedAt entity
}
getCommentByIdStmt :: Expr CommentId -> Query (CommentEntity Expr)
getCommentByIdStmt commentId = do
@ -75,35 +78,39 @@ getCommentsByArticleIdStmt articleId = do
return comment
insertCommentStmt :: Comment -> Insert [CommentId]
insertCommentStmt comment = Insert
{ into = commentSchema
, rows = values [
CommentEntity
{ entityCommentId = unsafeCastExpr $ nextval "comments_comment_id_seq"
, entityCommentUUID = lit $ commentUUID comment
, entityCommentBody = lit $ commentBody comment
, entityCommentArticleId = lit $ commentArticleId comment
, entityCommentAuthorId = lit $ commentAuthorId comment
, entityCommentCreatedAt = now
, entityCommentUpdatedAt = now
}
]
, onConflict = Abort
, returning = Projection entityCommentId
}
insertCommentStmt comment =
Insert
{ into = commentSchema
, rows =
values
[ CommentEntity
{ entityCommentId = unsafeCastExpr $ nextval "comments_comment_id_seq"
, entityCommentUUID = lit $ commentUUID comment
, entityCommentBody = lit $ commentBody comment
, entityCommentArticleId = lit $ commentArticleId comment
, entityCommentAuthorId = lit $ commentAuthorId comment
, entityCommentCreatedAt = now
, entityCommentUpdatedAt = now
}
]
, onConflict = Abort
, returning = Projection entityCommentId
}
deleteCommentStmt :: CommentId -> Delete Int64
deleteCommentStmt commentId = Delete
{ from = commentSchema
, using = pure ()
, deleteWhere = \_ row -> entityCommentId row ==. lit commentId
, returning = NumberOfRowsAffected
}
deleteCommentStmt commentId =
Delete
{ from = commentSchema
, using = pure ()
, deleteWhere = \_ row -> entityCommentId row ==. lit commentId
, returning = NumberOfRowsAffected
}
deleteCommentByArticleIdStmt :: ArticleId -> Delete Int64
deleteCommentByArticleIdStmt articleId = Delete
{ from = commentSchema
, using = pure ()
, deleteWhere = \_ row -> entityCommentArticleId row ==. lit articleId
, returning = NumberOfRowsAffected
}
deleteCommentByArticleIdStmt articleId =
Delete
{ from = commentSchema
, using = pure ()
, deleteWhere = \_ row -> entityCommentArticleId row ==. lit articleId
, returning = NumberOfRowsAffected
}

73
src/Conduit/Db/Schema/Favorite.hs
View File

@ -1,20 +1,20 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Conduit.Db.Schema.Favorite where
import Conduit.App
import Conduit.Core.Article
import Conduit.Core.User
import RIO
import Rel8
import Conduit.App
import Conduit.Core.User
import Conduit.Core.Article
data FavoriteEntity f = FavoriteEntity
{ favoriteUserId :: Column f UserId
{ favoriteUserId :: Column f UserId
, favoriteArticleId :: Column f ArticleId
}
deriving stock (Generic)
@ -23,38 +23,43 @@ data FavoriteEntity f = FavoriteEntity
deriving stock instance f ~ Result => Show (FavoriteEntity f)
favoriteSchema :: TableSchema (FavoriteEntity Name)
favoriteSchema = TableSchema
{ name = "favorited"
, schema = Nothing
, columns = FavoriteEntity
{ favoriteUserId = "favor_user_id"
, favoriteArticleId = "favor_article_id"
favoriteSchema =
TableSchema
{ name = "favorited"
, schema = Nothing
, columns =
FavoriteEntity
{ favoriteUserId = "favor_user_id"
, favoriteArticleId = "favor_article_id"
}
}
}
addFavoritedArticleStmt :: UserId -> ArticleId -> Insert Int64
addFavoritedArticleStmt currentUserId targetArticleId = Insert
{ into = favoriteSchema
, rows = values [ FavoriteEntity (lit currentUserId) (lit targetArticleId) ]
, onConflict = DoNothing
, returning = NumberOfRowsAffected
}
addFavoritedArticleStmt currentUserId targetArticleId =
Insert
{ into = favoriteSchema
, rows = values [FavoriteEntity (lit currentUserId) (lit targetArticleId)]
, onConflict = DoNothing
, returning = NumberOfRowsAffected
}
removeFavoritedArticleStmt :: UserId -> ArticleId -> Delete Int64
removeFavoritedArticleStmt userId articleId' = Delete
{ from = favoriteSchema
, using = pure ()
, deleteWhere = \_ row -> favoriteArticleId row ==. lit articleId' &&. favoriteUserId row ==. lit userId
, returning = NumberOfRowsAffected
}
removeFavoritedArticleStmt userId articleId' =
Delete
{ from = favoriteSchema
, using = pure ()
, deleteWhere = \_ row -> favoriteArticleId row ==. lit articleId' &&. favoriteUserId row ==. lit userId
, returning = NumberOfRowsAffected
}
removeAllFavoritesByArticleIdStmt :: ArticleId -> Delete Int64
removeAllFavoritesByArticleIdStmt articleId' = Delete
{ from = favoriteSchema
, using = pure ()
, deleteWhere = \_ row -> favoriteArticleId row ==. lit articleId'
, returning = NumberOfRowsAffected
}
removeAllFavoritesByArticleIdStmt articleId' =
Delete
{ from = favoriteSchema
, using = pure ()
, deleteWhere = \_ row -> favoriteArticleId row ==. lit articleId'
, returning = NumberOfRowsAffected
}
getFavoritedCountOfArticleStmt :: Expr ArticleId -> Query (Expr Int64)
getFavoritedCountOfArticleStmt articleId = countRows $ do

43
src/Conduit/Db/Schema/Tag.hs
View File

@ -1,18 +1,18 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Conduit.Db.Schema.Tag where
import Conduit.Core.Article
import RIO
import Rel8
import Conduit.Core.Article
data TagEntity f = TagEntity
{ entityTagId :: Column f TagId
{ entityTagId :: Column f TagId
, entityTagText :: Column f Text
}
deriving stock (Generic)
@ -21,14 +21,16 @@ data TagEntity f = TagEntity
deriving stock instance f ~ Result => Show (TagEntity f)
tagSchema :: TableSchema (TagEntity Name)
tagSchema = TableSchema
{ name = "tags"
, schema = Nothing
, columns = TagEntity
{ entityTagId = "tag_id"
, entityTagText = "tag_text"
tagSchema =
TableSchema
{ name = "tags"
, schema = Nothing
, columns =
TagEntity
{ entityTagId = "tag_id"
, entityTagText = "tag_text"
}
}
}
getTagIdStmt :: Text -> Query (Expr TagId)
getTagIdStmt tag = do
@ -37,9 +39,10 @@ getTagIdStmt tag = do
return $ entityTagId tagEntity
insertTagStmt :: Text -> Insert [TagId]
insertTagStmt tag = Insert
{ into = tagSchema
, rows = values [TagEntity (unsafeCastExpr $ nextval "tags_tag_id_seq") (lit tag)]
, onConflict = Abort
, returning = Projection entityTagId
}
insertTagStmt tag =
Insert
{ into = tagSchema
, rows = values [TagEntity (unsafeCastExpr $ nextval "tags_tag_id_seq") (lit tag)]
, onConflict = Abort
, returning = Projection entityTagId
}

120
src/Conduit/Db/Schema/User.hs
View File

@ -1,27 +1,27 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Conduit.Db.Schema.User where
import Conduit.Core.Password
import Conduit.Core.User
import Hasql.Connection (Connection)
import RIO hiding (set)
import Rel8
import Hasql.Connection ( Connection )
import Conduit.Core.User
import Conduit.Core.Password
data UserEntity f = UserEntity
{ entityUserId :: Column f UserId
, entityUserName :: Column f Username
, entityUserEmail :: Column f EmailAddress
{ entityUserId :: Column f UserId
, entityUserName :: Column f Username
, entityUserEmail :: Column f EmailAddress
, entityUserPassword :: Column f HashedPassword
, entityUserBio :: Column f Text
, entityUserImage :: Column f Text
, entityUserBio :: Column f Text
, entityUserImage :: Column f Text
}
deriving stock (Generic)
deriving anyclass (Rel8able)
@ -29,40 +29,45 @@ data UserEntity f = UserEntity
deriving stock instance f ~ Result => Show (UserEntity f)
userSchema :: TableSchema (UserEntity Name)
userSchema = TableSchema
{ name = "users"
, schema = Nothing
, columns = UserEntity
{ entityUserId = "user_id"
, entityUserName = "user_username"
, entityUserEmail = "user_email"
, entityUserPassword = "user_password"
, entityUserBio = "user_bio"
, entityUserImage = "user_image"
userSchema =
TableSchema
{ name = "users"
, schema = Nothing
, columns =
UserEntity
{ entityUserId = "user_id"
, entityUserName = "user_username"
, entityUserEmail = "user_email"
, entityUserPassword = "user_password"
, entityUserBio = "user_bio"
, entityUserImage = "user_image"
}
}
}
mapUserEntityToUser :: UserEntity Result -> User
mapUserEntityToUser entity = User
{ userId = entityUserId entity
, userName = entityUserName entity
, userEmail = entityUserEmail entity
, userBio = entityUserBio entity
, userImage = entityUserImage entity
}
mapUserEntityToUser entity =
User
{ userId = entityUserId entity
, userName = entityUserName entity
, userEmail = entityUserEmail entity
, userBio = entityUserBio entity
, userImage = entityUserImage entity
}
updateUserProperties :: User -> UserEntity Expr -> UserEntity Expr
updateUserProperties user expr = expr
{ entityUserName = lit (userName user)
, entityUserEmail = lit (userEmail user)
, entityUserBio = lit (userBio user)
, entityUserImage = lit (userImage user)
}
updateUserProperties user expr =
expr
{ entityUserName = lit (userName user)
, entityUserEmail = lit (userEmail user)
, entityUserBio = lit (userBio user)
, entityUserImage = lit (userImage user)
}
updatePassword :: HashedPassword -> UserEntity Expr -> UserEntity Expr
updatePassword hash expr = expr
{ entityUserPassword = lit hash
}
updatePassword :: HashedPassword -> UserEntity Expr -> UserEntity Expr
updatePassword hash expr =
expr
{ entityUserPassword = lit hash
}
getUserByIdStmt :: Expr UserId -> Query (UserEntity Expr)
getUserByIdStmt uid = do
@ -76,27 +81,30 @@ getUserByNameStmt name = do
where_ $ entityUserName a ==. lit name
return a
getUserByEmailStmt :: EmailAddress -> Query (UserEntity Expr)
getUserByEmailStmt :: EmailAddress -> Query (UserEntity Expr)
getUserByEmailStmt email = do
a <- each userSchema
where_ $ entityUserEmail a ==. lit email
return a
insertUserStmt :: User -> HashedPassword -> Insert [UserId]
insertUserStmt user hash = Insert
{ into = userSchema
, rows = values [ UserEntity
{ entityUserId = unsafeCastExpr $ nextval "users_user_id_seq"
, entityUserName = lit (userName user)
, entityUserEmail = lit (userEmail user)
, entityUserBio = lit (userBio user)
, entityUserImage = lit (userImage user)
, entityUserPassword = lit hash
}
]
, onConflict = DoNothing
, returning = Projection entityUserId
}
insertUserStmt user hash =
Insert
{ into = userSchema
, rows =
values
[ UserEntity
{ entityUserId = unsafeCastExpr $ nextval "users_user_id_seq"
, entityUserName = lit (userName user)
, entityUserEmail = lit (userEmail user)
, entityUserBio = lit (userBio user)
, entityUserImage = lit (userImage user)
, entityUserPassword = lit hash
}
]
, onConflict = DoNothing
, returning = Projection entityUserId
}
updateUserStmt :: User -> Maybe HashedPassword -> Update Int64
updateUserStmt user mbPassword =
@ -110,4 +118,4 @@ updateUserStmt user mbPassword =
where
setter _ = case mbPassword of
Just password -> updatePassword password . updateUserProperties user
_ -> updateUserProperties user
_ -> updateUserProperties user

46
src/Conduit/Db/Schema/UserFollow.hs
View File

@ -1,18 +1,18 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Conduit.Db.Schema.UserFollow where
import Conduit.Core.User
import RIO
import Rel8
import Conduit.Core.User
data UserFollowEntity f = UserFollowEntity
{ fwsUserId :: Column f UserId
{ fwsUserId :: Column f UserId
, fwsFollowingUserId :: Column f UserId
}
deriving stock (Generic)
@ -21,31 +21,35 @@ data UserFollowEntity f = UserFollowEntity
deriving stock instance f ~ Result => Show (UserFollowEntity f)
userFollowSchema :: TableSchema (UserFollowEntity Name)
userFollowSchema = TableSchema
{ name = "follows"
, schema = Nothing
, columns = UserFollowEntity
{ fwsUserId = "fws_user_id"
, fwsFollowingUserId = "fws_follows_user_id"
userFollowSchema =
TableSchema
{ name = "follows"
, schema = Nothing
, columns =
UserFollowEntity
{ fwsUserId = "fws_user_id"
, fwsFollowingUserId = "fws_follows_user_id"
}
}
}
createFollowshipStmt :: UserId -> UserId -> Insert Int64
createFollowshipStmt currentUserId toFollowUserId =
Insert
{ into = userFollowSchema
, rows = values
[ UserFollowEntity
{ fwsUserId = lit currentUserId
, fwsFollowingUserId = lit toFollowUserId
}
]
, rows =
values
[ UserFollowEntity
{ fwsUserId = lit currentUserId
, fwsFollowingUserId = lit toFollowUserId
}
]
, onConflict = DoNothing
, returning = NumberOfRowsAffected
}
removeFollowshipStmt :: UserId -> UserId -> Delete Int64
removeFollowshipStmt currentUserId followingUserId = Delete
removeFollowshipStmt currentUserId followingUserId =
Delete
{ from = userFollowSchema
, using = pure ()
, deleteWhere = \_ o -> (fwsUserId o ==. lit currentUserId) &&. (fwsFollowingUserId o ==. lit followingUserId)

30
src/Conduit/Db/Transaction.hs
View File

@ -1,19 +1,19 @@
{-# LANGUAGE RankNTypes #-}
module Conduit.Db.Transaction where
import RIO
import Conduit.App
import Conduit.Config
import Conduit.Environment
import Data.List
import Hasql.Connection (Connection)
import Hasql.Pool ( Pool, UsageError(..), acquire )
import Hasql.Pool (Pool, UsageError (..), acquire)
import qualified Hasql.Pool as Pool
import Hasql.Transaction ( Transaction, condemn, statement, sql )
import qualified Hasql.Session as Session
import qualified Hasql.Transaction.Sessions as Hasql
import Hasql.Statement (Statement)
import Conduit.Config
import Conduit.App
import Conduit.Environment
import Hasql.Transaction (Transaction, condemn, sql, statement)
import qualified Hasql.Transaction.Sessions as Hasql
import RIO
loadPool :: ByteString -> Int -> IO Pool
loadPool connectString poolSize = acquire poolSize (Just 10) connectString
@ -35,7 +35,7 @@ runTransactionWithPool pool transaction = do
runStmt :: Statement () a -> Transaction a
runStmt = statement ()
runTransaction :: forall a m env . (HasDbPool env, MonadReader env m, MonadIO m) => Transaction a -> m a
runTransaction :: forall a m env. (HasDbPool env, MonadReader env m, MonadIO m) => Transaction a -> m a
runTransaction transaction = do
pool <- getDbPool'
runTransactionWithPool pool transaction
@ -44,8 +44,10 @@ executeStmt :: Statement () a -> AppM a
executeStmt = runTransaction . runStmt
truncateTables :: [Text] -> Transaction ()
truncateTables tables = sql $ mconcat
[ "TRUNCATE "
, fromString $ intercalate ", " (map show tables)
," RESTART IDENTITY;"
]
truncateTables tables =
sql $
mconcat
[ "TRUNCATE "
, fromString $ intercalate ", " (map show tables)
, " RESTART IDENTITY;"
]

7
src/Conduit/Environment.hs
View File

@ -1,15 +1,16 @@
{-# LANGUAGE RankNTypes #-}
module Conduit.Environment where
import Hasql.Pool (Pool)
import Crypto.JOSE (JWK)
import Hasql.Pool (Pool)
import RIO (MonadReader, ask, (<&>))
class HasDbPool env where
getDbPool :: env -> Pool
getDbPool :: env -> Pool
class HasJwtKey env where
getJwtKey :: env -> JWK
getJwtKey :: env -> JWK
getDbPool' :: (HasDbPool env, MonadReader env m) => m Pool
getDbPool' = ask <&> getDbPool

65
src/Conduit/JWT.hs
View File

@ -1,45 +1,46 @@
module Conduit.JWT where
import RIO hiding ((^?), (^.))
import Conduit.Core.User (Username (getUsername))
import Control.Lens
import Control.Monad.Except (runExceptT)
import Crypto.JWT
( JWK,
bestJWSAlg,
ClaimsSet,
JWTError,
decodeCompact,
encodeCompact,
newJWSHeader,
claimAud,
claimExp,
claimIat,
claimIss,
claimSub,
defaultJWTValidationSettings,
emptyClaimsSet,
signClaims,
string,
verifyClaims,
Audience(Audience),
NumericDate(NumericDate) )
import Control.Lens
import Data.Time.Clock ( getCurrentTime, nominalDay, addUTCTime )
( Audience (Audience)
, ClaimsSet
, JWK
, JWTError
, NumericDate (NumericDate)
, bestJWSAlg
, claimAud
, claimExp
, claimIat
, claimIss
, claimSub
, decodeCompact
, defaultJWTValidationSettings
, emptyClaimsSet
, encodeCompact
, newJWSHeader
, signClaims
, string
, verifyClaims
)
import Data.ByteString.Lazy (fromStrict, toStrict)
import qualified Data.Text as T
import Data.Text.Encoding ( decodeUtf8 )
import Conduit.Core.User ( Username(getUsername) )
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (addUTCTime, getCurrentTime, nominalDay)
import RIO hiding ((^.), (^?))
mkClaims :: Username -> IO ClaimsSet
mkClaims name = do
currentTime <- getCurrentTime
let expiredAt = addUTCTime nominalDay currentTime
pure $ emptyClaimsSet
& claimIss ?~ "conduit-server"
& claimAud ?~ Audience ["conduit-client"]
& claimIat ?~ NumericDate currentTime
& claimExp ?~ NumericDate expiredAt
& claimSub ?~ (fromString . T.unpack . getUsername) name
pure $
emptyClaimsSet
& claimIss ?~ "conduit-server"
& claimAud ?~ Audience ["conduit-client"]
& claimIat ?~ NumericDate currentTime
& claimExp ?~ NumericDate expiredAt
& claimSub ?~ (fromString . T.unpack . getUsername) name
signJwt :: JWK -> ClaimsSet -> IO (Either JWTError Text)
signJwt jwk claims = runExceptT $ do
@ -53,4 +54,4 @@ verifyJwt key token = runExceptT $ do
verifyClaims (defaultJWTValidationSettings audCheck) key signedJwt
getSubject :: ClaimsSet -> Maybe Text
getSubject claimSet = fromMaybe "" (claimSet ^. claimSub) ^? string
getSubject claimSet = fromMaybe "" (claimSet ^. claimSub) ^? string

89
src/Conduit/Repository/Article.hs
View File

@ -1,38 +1,38 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Conduit.Repository.Article where
import RIO
import Rel8
import Hasql.Transaction (Transaction)
import Conduit.App
import Conduit.Core.Article
import Conduit.Core.User
import Conduit.Db
import Conduit.Util
import Data.Functor.Contravariant
import Data.List (head, (\\))
import Conduit.Core.User
import Conduit.Core.Article
import Conduit.Db
import Conduit.App
import Conduit.Util
import Hasql.Transaction (Transaction)
import RIO
import Rel8
data ArticleFilters = ArticleFilters
{ getTagFilter :: Maybe TagId
{ getTagFilter :: Maybe TagId
, getFavoriteFilter :: Maybe UserId
, getAuthorFilter :: Maybe UserId
, getAuthorFilter :: Maybe UserId
}
data Pagination = Pagination
{ pageNum :: Int64
{ pageNum :: Int64
, pageSize :: Int64
}
data EnrichedArticle = EnrichedArticle
{ enrArticle :: Article
, enrAuthor :: User
{ enrArticle :: Article
, enrAuthor :: User
, enrFollowingAuthor :: Bool
, enrIsFavorited :: Bool
, enrFavoritedCount :: Int64
, enrIsFavorited :: Bool
, enrFavoritedCount :: Int64
}
type EnrichedArticleQuery = Query (MaybeTable Expr (ListTable Expr (TagEntity Expr)), UserEntity Expr, Expr Bool, Expr Bool, Expr Int64)
@ -42,17 +42,18 @@ type EnrichedArticleResult = (Maybe [TagEntity Result], UserEntity Result, Bool,
mapArticleEntityWithTagsToArticle :: (ArticleEntity Result, [TagEntity Result]) -> Article
mapArticleEntityWithTagsToArticle (article, tags) =
let article' = mapArticleEntityToArticle article
in article' { articleTags = map entityTagText tags}
in article' {articleTags = map entityTagText tags}
enrichedArticle :: (ArticleEntity Result, EnrichedArticleResult)
-> EnrichedArticle
enrichedArticle ::
(ArticleEntity Result, EnrichedArticleResult) ->
EnrichedArticle
enrichedArticle (articleEntity, (mbTags, authorEntity, followingAuthor, favorited, favoritedCount)) =
EnrichedArticle
(mapArticleEntityWithTagsToArticle (articleEntity, fromMaybe [] mbTags))
(mapUserEntityToUser authorEntity)
followingAuthor
favorited
favoritedCount
EnrichedArticle
(mapArticleEntityWithTagsToArticle (articleEntity, fromMaybe [] mbTags))
(mapUserEntityToUser authorEntity)
followingAuthor
favorited
favoritedCount
filterArticleByAuthorStmt :: ArticleEntity Expr -> UserId -> Expr Bool
filterArticleByAuthorStmt article uid = entityArticleAuthorId article ==. lit uid
@ -75,20 +76,21 @@ getAllArticleStmt filters = do
forM_ tag' $ filterArticleByTagStmt article
return article
where
tag' = getTagFilter filters
tag' = getTagFilter filters
favorite' = getFavoriteFilter filters
author' = getAuthorFilter filters
author' = getAuthorFilter filters
getPagedArticleStmt :: Int64 -> Int64 -> ArticleFilters -> Query (ArticleEntity Expr)
getPagedArticleStmt pageSize page filters =
limit (fromIntegral pageSize)
$ offset (fromIntegral page)
$ orderBy (entityArticleCreatedAt >$< desc)
$ getAllArticleStmt filters
limit (fromIntegral pageSize) $
offset (fromIntegral page) $
orderBy (entityArticleCreatedAt >$< desc) $
getAllArticleStmt filters
getTagsOfArticleStmt :: (Column f ArticleId ~ Expr ArticleId)
=> ArticleEntity f
-> Query (MaybeTable Expr (ListTable Expr (TagEntity Expr)))
getTagsOfArticleStmt ::
(Column f ArticleId ~ Expr ArticleId) =>
ArticleEntity f ->
Query (MaybeTable Expr (ListTable Expr (TagEntity Expr)))
getTagsOfArticleStmt article = Rel8.optional $ aggregate $ do
tagId <- getAllArticleTagsStmt (entityArticleId article)
tag <- each tagSchema
@ -113,7 +115,7 @@ createArticle article = runTransaction $ do
Just articleId' -> do
tagIds <- mapM getOrCreateTagId' (articleTags article)
_ <- runStmt $ insert $ insertArticleTagsStmt articleId' tagIds
return $ Just article { articleId = articleId' }
return $ Just article {articleId = articleId'}
Nothing -> return Nothing
getTagId' :: Text -> Transaction (Maybe TagId)
@ -125,9 +127,10 @@ getTagId tag = runTransaction $ getTagId' tag
getOrCreateTagId' :: Text -> Transaction TagId
getOrCreateTagId' tag = do
tagId <- getTagId' tag
maybe (runStmt $ head <$> insert (insertTagStmt tag))
return
tagId
maybe
(runStmt $ head <$> insert (insertTagStmt tag))
return
tagId
getEnrichedArticleById :: Maybe User -> ArticleId -> AppM (Maybe EnrichedArticle)
getEnrichedArticleById mbUser id = do
@ -145,9 +148,9 @@ getArticleById id = do
getEnrichedArticleBySlug :: Maybe User -> Slug -> AppM (Maybe EnrichedArticle)
getEnrichedArticleBySlug mbUser slug = do
records <- executeStmt $ select $ do
article <- getArticleEntityBySlugStmt $ litExpr slug
enrichedData <- getArticleEnrichedDataStmt mbUser article
return (article, enrichedData)
article <- getArticleEntityBySlugStmt $ litExpr slug
enrichedData <- getArticleEnrichedDataStmt mbUser article
return (article, enrichedData)
return $ listToMaybe $ map enrichedArticle records
getArticleBySlug :: Slug -> AppM (Maybe Article)
@ -168,7 +171,7 @@ getPagedArticle mbUser p filters = do
return (total, pagedResults)
return (map enrichedArticle pagedResults, fromMaybe 0 . listToMaybe $ total)
checkFavorite :: User -> ArticleId -> AppM Bool
checkFavorite :: User -> ArticleId -> AppM Bool
checkFavorite user articleId = do
exists <- executeStmt $ select $ checkFavoriteStmt (userId user) (litExpr articleId)
return $ exists == [True]

16
src/Conduit/Repository/Comment.hs
View File

@ -1,17 +1,17 @@
{-# LANGUAGE RankNTypes #-}
module Conduit.Repository.Comment where
import RIO
import Rel8
import Data.UUID
import Conduit.App
import Conduit.Core.User
import Conduit.Core.Article
import Conduit.Core.Comment
import Conduit.Core.User
import Conduit.Db
import Data.UUID
import RIO
import Rel8
type EnrichedComment = (Comment, User, Bool )
type EnrichedComment = (Comment, User, Bool)
getEnrichedCommentsByArticleId :: Maybe User -> ArticleId -> AppM [EnrichedComment]
getEnrichedCommentsByArticleId mbUser articleId = do
@ -28,7 +28,7 @@ getCommentById commentId = do
return $ listToMaybe $ map mapCommentEntityToComment comments
getCommentByUUID :: UUID -> AppM (Maybe Comment)
getCommentByUUID uuid = do
getCommentByUUID uuid = do
comments <- executeStmt $ select $ getCommentByUUIDStmt (litExpr uuid)
return $ listToMaybe $ map mapCommentEntityToComment comments
@ -37,7 +37,7 @@ addComment comment = do
commentId <- executeStmt $ insert (insertCommentStmt comment)
return $ updateCommentId =<< listToMaybe commentId
where
updateCommentId commentId' = Just $ comment {commentId = commentId' }
updateCommentId commentId' = Just $ comment {commentId = commentId'}
deleteCommentById :: CommentId -> AppM Bool
deleteCommentById commentId = do

26
src/Conduit/Repository/User.hs
View File

@ -1,16 +1,16 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module Conduit.Repository.User where
import Conduit.App
import Conduit.Core.Password
import Conduit.Core.User
import Conduit.Db
import RIO
import Rel8
import Conduit.App
import Conduit.Core.User
import Conduit.Core.Password
import Conduit.Db
getUserById :: UserId -> AppM (Maybe User)
getUserById uid = do
users <- executeStmt $ select $ getUserByIdStmt (litExpr uid)
@ -26,30 +26,28 @@ getUserByEmail email = do
users <- executeStmt $ select $ getUserByEmailStmt email
return $ listToMaybe $ map mapUserEntityToUser users
getUserByEmailAndPassword :: EmailAddress -> Password -> AppM (Maybe User)
getUserByEmailAndPassword :: EmailAddress -> Password -> AppM (Maybe User)
getUserByEmailAndPassword email password = do
users <- executeStmt $ select $ getUserByEmailStmt email
return $ verifyPassword' =<< listToMaybe users
where
verifyPassword' user =
if verifyPassword password (entityUserPassword user)
then
Just $ mapUserEntityToUser user
else
Nothing
then Just $ mapUserEntityToUser user
else Nothing
saveNewUser :: User -> Password -> AppM (Maybe User)
saveNewUser user password = do
hashedPwdAndSalt <- liftIO $ hashPassword password
userIds <- executeStmt $ insert $ insertUserStmt user hashedPwdAndSalt
return $ listToMaybe userIds >>= \uid -> Just $ user { userId = uid }
return $ listToMaybe userIds >>= \uid -> Just $ user {userId = uid}
updateUser :: User -> Maybe Password -> AppM Bool
updateUser user mbPassword = do
hashAndSalt <-
case mbPassword of
Just password -> liftIO $ Just <$> hashPassword password
_ -> return Nothing
_ -> return Nothing
rows <- executeStmt $ update $ updateUserStmt user hashAndSalt
return $ rows > 0
@ -60,7 +58,7 @@ checkFollowship user following = do
followUser :: User -> UserId -> AppM Bool
followUser user toFollow = do
rows <-executeStmt $ insert $ createFollowshipStmt (userId user) toFollow
rows <- executeStmt $ insert $ createFollowshipStmt (userId user) toFollow
return $ rows == 1
unfollowUser :: User -> UserId -> AppM Bool

20
src/Conduit/Util.hs
View File

@ -1,21 +1,23 @@
{-# LANGUAGE RankNTypes #-}
module Conduit.Util where
import RIO
import Control.Monad.Trans.Maybe ( MaybeT(..) )
import Data.Aeson ( defaultOptions, Options(fieldLabelModifier) )
import Data.List ( head, tail )
import Data.Char ( toLower )
import Data.UUID
import System.Random
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Aeson (Options (fieldLabelModifier), defaultOptions)
import Data.ByteArray (Bytes, convert)
import Data.Char (toLower)
import Data.List (head, tail)
import Data.Text.Encoding (decodeUtf8)
import System.IO ( hPutStrLn )
import Data.UUID
import RIO
import System.IO (hPutStrLn)
import System.Random
toJsonOptions :: Int -> Options
toJsonOptions prefixLength =
defaultOptions
{ fieldLabelModifier = headToLower . drop prefixLength }
{ fieldLabelModifier = headToLower . drop prefixLength
}
where
headToLower x = toLower (head x) : tail x

9
stack-9.2.7.yaml Normal file
View File

@ -0,0 +1,9 @@
resolver: lts-20.21
packages:
- .
allow-newer: true
extra-deps:
- unix-compat-0.7

2
stack.yaml
View File

@ -6,4 +6,4 @@ packages:
allow-newer: true
extra-deps:
- unix-compat-0.7
- unix-compat-0.7

13
test/Test/Conduit/Api/AuthApiSpec.hs
View File

@ -1,19 +1,20 @@
{-# LANGUAGE RankNTypes #-}
module Test.Conduit.Api.AuthApiSpec where
import RIO
import Conduit.Api.Auth
import Conduit.Api.Common
import Data.Aeson
import Data.Maybe
import Test.Hspec
import Network.Wai.Test
import Network.HTTP.Types
import Conduit.Api.Common
import Conduit.Api.Auth
import Network.Wai.Test
import RIO
import Test.Conduit.TestHelper
import Test.Hspec
spec :: Spec
spec =
context "Login/Register user" $ afterAll_ cleanUpDb $ do
context "Login/Register user" $ afterAll_ cleanUpDb $ do
withApplication $ do
it "should register a new user" $ do
response <- registerNewUser "test001"

179
test/Test/Conduit/Api/StorySpec.hs
View File

@ -1,23 +1,24 @@
module Test.Conduit.Api.StorySpec where
import Test.Hspec
import RIO
import qualified RIO.List as L
import qualified Test.Hspec.Wai as THW
import Test.Conduit.TestHelper
import Conduit.Api.Common
import Conduit.Api.User
import Conduit.Api.Article
import Conduit.Api.Comment
import Data.Maybe
import Conduit.Api.Common
import Conduit.Api.User
import Data.Aeson
import Network.Wai.Test
import Network.HTTP.Types
import qualified Data.ByteString as B
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types
import Network.Wai.Test
import RIO
import qualified RIO.List as L
import Test.Conduit.TestHelper
import Test.Hspec
import qualified Test.Hspec.Wai as THW
-- * popularism is defined by the number of comments
-- A user comes to the website and sees a list of most popular articles
-- A user reads a few articles
-- A user finds his favourite author and looks for a list of article from this author sorted by most recent
@ -29,86 +30,88 @@ import qualified Data.Text.Encoding as T
spec :: Spec
spec = do
let username = "test"
context "Story APIs"
$ beforeAll_ (setupTestUser username)
$ beforeAll_ (setupTestArticle "1")
$ afterAll_ cleanUpDb
$ withApplication
$ do
it "should get a list of articles" $ do
response <- THW.request methodGet "/api/articles" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe ArticlesResponse
liftIO $ mbBody `shouldNotBe` Nothing
let (ArticlesResponse count [article]) = fromJust mbBody
liftIO $ count `shouldBe` 1
liftIO $ articleDataTitle article `shouldBe` "test article title"
context "Story APIs" $
beforeAll_ (setupTestUser username) $
beforeAll_ (setupTestArticle "1") $
afterAll_ cleanUpDb $
withApplication $
do
it "should get a list of articles" $ do
response <- THW.request methodGet "/api/articles" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe ArticlesResponse
liftIO $ mbBody `shouldNotBe` Nothing
let (ArticlesResponse count [article]) = fromJust mbBody
liftIO $ count `shouldBe` 1
liftIO $ articleDataTitle article `shouldBe` "test article title"
it "should get an article by slug" $ do
response <- THW.request methodGet "/api/articles/test-article" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe (BoxedArticle ArticleData)
liftIO $ mbBody `shouldNotBe` Nothing
let (BoxedArticle articleData) = fromJust mbBody
liftIO $ articleDataBody articleData `shouldBe` "test article body"
liftIO $ articleDataTitle articleData `shouldBe` "test article title"
it "should get an article by slug" $ do
response <- THW.request methodGet "/api/articles/test-article" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe (BoxedArticle ArticleData)
liftIO $ mbBody `shouldNotBe` Nothing
let (BoxedArticle articleData) = fromJust mbBody
liftIO $ articleDataBody articleData `shouldBe` "test article body"
liftIO $ articleDataTitle articleData `shouldBe` "test article title"
it "should get a list of articles from a specific author" $ do
response <- THW.request methodGet "/api/articles?author=test" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe ArticlesResponse
liftIO $ mbBody `shouldNotBe` Nothing
let (ArticlesResponse count [article]) = fromJust mbBody
liftIO $ count `shouldBe` 1
liftIO $ articleDataTitle article `shouldBe` "test article title"
it "should get a list of articles from a specific author" $ do
response <- THW.request methodGet "/api/articles?author=test" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe ArticlesResponse
liftIO $ mbBody `shouldNotBe` Nothing
let (ArticlesResponse count [article]) = fromJust mbBody
liftIO $ count `shouldBe` 1
liftIO $ articleDataTitle article `shouldBe` "test article title"
it "should fail to comment without authentication" $ do
let comment = BoxedComment (NewCommentData "a good test article")
response <- THW.request
methodPost
"/api/articles/test-article/comments"
[("Content-Type", "application/json")]
$ encode comment
liftIO $ statusCode (simpleStatus response) `shouldBe` 401
let mbBody = decode (simpleBody response) :: Maybe (BoxedComment CommentData)
liftIO $ mbBody `shouldBe` Nothing
it "should fail to comment without authentication" $ do
let comment = BoxedComment (NewCommentData "a good test article")
response <-
THW.request
methodPost
"/api/articles/test-article/comments"
[("Content-Type", "application/json")]
$ encode comment
liftIO $ statusCode (simpleStatus response) `shouldBe` 401
let mbBody = decode (simpleBody response) :: Maybe (BoxedComment CommentData)
liftIO $ mbBody `shouldBe` Nothing
it "should add a comment to an article" $ do
let body = "a good test article"
let comment = BoxedComment (NewCommentData body)
token <- getAccessToken username
response <-
THW.request
methodPost
"/api/articles/test-article/comments"
[ ("Content-Type", "application/json")
, ("Authorization", T.encodeUtf8 $ T.append "Token " token)]
$ encode comment
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe (BoxedComment CommentData)
liftIO $ mbBody `shouldNotBe` Nothing
let (BoxedComment commentData) = fromJust mbBody
liftIO $ commentDataBody commentData `shouldBe` body
liftIO $ (profileUsername $ commentDataAuthor commentData) `shouldBe` username
it "should create an article" $ do
let title = "test article title"
let description = "test article description"
let body = "test article body"
let tagList = []
let article = BoxedArticle (NewArticleData title description body tagList)
token <- getAccessToken username
response <-
THW.request
methodPost
"/api/articles"
[ ("Content-Type", "application/json")
, ("Authorization", T.encodeUtf8 $ T.append "Token " token)]
$ encode article
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe (BoxedArticle ArticleData)
liftIO $ mbBody `shouldNotBe` Nothing
let (BoxedArticle articleData) = fromJust mbBody
liftIO $ articleDataBody articleData `shouldBe` body
liftIO $ (profileUsername $ articleDataAuthor articleData) `shouldBe` username
it "should add a comment to an article" $ do
let body = "a good test article"
let comment = BoxedComment (NewCommentData body)
token <- getAccessToken username
response <-
THW.request
methodPost
"/api/articles/test-article/comments"
[ ("Content-Type", "application/json")
, ("Authorization", T.encodeUtf8 $ T.append "Token " token)
]
$ encode comment
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe (BoxedComment CommentData)
liftIO $ mbBody `shouldNotBe` Nothing
let (BoxedComment commentData) = fromJust mbBody
liftIO $ commentDataBody commentData `shouldBe` body
liftIO $ (profileUsername $ commentDataAuthor commentData) `shouldBe` username
it "should create an article" $ do
let title = "test article title"
let description = "test article description"
let body = "test article body"
let tagList = []
let article = BoxedArticle (NewArticleData title description body tagList)
token <- getAccessToken username
response <-
THW.request
methodPost
"/api/articles"
[ ("Content-Type", "application/json")
, ("Authorization", T.encodeUtf8 $ T.append "Token " token)
]
$ encode article
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe (BoxedArticle ArticleData)
liftIO $ mbBody `shouldNotBe` Nothing
let (BoxedArticle articleData) = fromJust mbBody
liftIO $ articleDataBody articleData `shouldBe` body
liftIO $ (profileUsername $ articleDataAuthor articleData) `shouldBe` username

84
test/Test/Conduit/Api/UserApiSpec.hs
View File

@ -1,55 +1,55 @@
module Test.Conduit.Api.UserApiSpec where
import Test.Hspec
import RIO
import qualified Test.Hspec.Wai as THW
import Test.Conduit.TestHelper
import Conduit.Api.Common
import Conduit.Api.User
import Data.Maybe
import Data.Aeson
import Network.Wai.Test
import Network.HTTP.Types
import qualified Data.ByteString as B
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types
import Network.Wai.Test
import RIO
import Test.Conduit.TestHelper
import Test.Hspec
import qualified Test.Hspec.Wai as THW
spec :: Spec
spec = do
let username = "test"
context "User APIs"
$ beforeAll_ (setupTestUser username)
$ afterAll_ cleanUpDb
$ withApplication
$ do
it "Get user detail with token" $ do
token <- getAccessToken username
response <-
THW.request
methodGet
"/api/user"
[("Authorization", T.encodeUtf8 $ T.append "Token " token)]
""
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe (UserData UserResponse)
liftIO $ mbBody `shouldNotBe` Nothing
let (UserData userResponse) = fromJust mbBody
liftIO $ urUsername userResponse `shouldBe` username
it "Update user" $ do
token <- getAccessToken username
response <-
THW.request
methodPut
"/api/user"
[ ("Content-Type", "application/json")
, ("Authorization", T.encodeUtf8 $ T.append "Token " token)]
"{ \"user\": { \"bio\": \"Test\", \"image\": \"URL\" }}"
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe (UserData UserResponse)
liftIO $ mbBody `shouldNotBe` Nothing
let (UserData userResponse) = fromJust mbBody
liftIO $ urUsername userResponse `shouldBe` username
liftIO $ urImage userResponse `shouldBe` "URL"
liftIO $ urBio userResponse `shouldBe` "Test"
context "User APIs" $
beforeAll_ (setupTestUser username) $
afterAll_ cleanUpDb $
withApplication $
do
it "Get user detail with token" $ do
token <- getAccessToken username
response <-
THW.request
methodGet
"/api/user"
[("Authorization", T.encodeUtf8 $ T.append "Token " token)]
""
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe (UserData UserResponse)
liftIO $ mbBody `shouldNotBe` Nothing
let (UserData userResponse) = fromJust mbBody
liftIO $ urUsername userResponse `shouldBe` username
it "Update user" $ do
token <- getAccessToken username
response <-
THW.request
methodPut
"/api/user"
[ ("Content-Type", "application/json")
, ("Authorization", T.encodeUtf8 $ T.append "Token " token)
]
"{ \"user\": { \"bio\": \"Test\", \"image\": \"URL\" }}"
liftIO $ statusCode (simpleStatus response) `shouldBe` 200
let mbBody = decode (simpleBody response) :: Maybe (UserData UserResponse)
liftIO $ mbBody `shouldNotBe` Nothing
let (UserData userResponse) = fromJust mbBody
liftIO $ urUsername userResponse `shouldBe` username
liftIO $ urImage userResponse `shouldBe` "URL"
liftIO $ urBio userResponse `shouldBe` "Test"

71
test/Test/Conduit/TestHelper.hs
View File

@ -22,11 +22,10 @@ import Network.Wai
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Test
import RIO
import System.IO (putStrLn)
import Test.Hspec
import Test.Hspec.Wai
import qualified Test.Hspec.Wai as THW
import System.IO (putStrLn)
import Conduit.Config
loadTestEnv :: IO AppEnv
loadTestEnv = do
@ -36,7 +35,8 @@ loadTestEnv = do
result <- autoMigrate pool
whenJust result $ \e -> do
error $ show e
let env = AppEnv
let env =
AppEnv
{ envDbPool = pool
, envJwtKey = jwtKey
}
@ -75,20 +75,21 @@ setupTestArticle userId = do
let articleBody = "test article body"
let articleUserId = userId
runSql $
sql $ mconcat
[ "INSERT INTO articles (article_slug, article_title, article_description, article_body, article_user_id)"
, "VALUES ('"
, T.encodeUtf8 articleSlug
, "', '"
, T.encodeUtf8 articleTitle
, "', '"
, T.encodeUtf8 articleDescription
, "', '"
, T.encodeUtf8 articleBody
, "', "
, T.encodeUtf8 articleUserId
, ");"
]
sql $
mconcat
[ "INSERT INTO articles (article_slug, article_title, article_description, article_body, article_user_id)"
, "VALUES ('"
, T.encodeUtf8 articleSlug
, "', '"
, T.encodeUtf8 articleTitle
, "', '"
, T.encodeUtf8 articleDescription
, "', '"
, T.encodeUtf8 articleBody
, "', "
, T.encodeUtf8 articleUserId
, ");"
]
setupTestUser :: Text -> IO ()
setupTestUser username = do
@ -96,17 +97,18 @@ setupTestUser username = do
let password = Password $ T.append username "password"
hash <- hashPassword password
runSql $
sql $ mconcat
[ "INSERT INTO users (user_email, user_username, user_password, user_bio, user_image)"
, "VALUES ('"
, T.encodeUtf8 email
, "', '"
, T.encodeUtf8 username
, "', '"
, T.encodeUtf8 . getHashedPasswd $ hash
, "', ''"
, ", '');"
]
sql $
mconcat
[ "INSERT INTO users (user_email, user_username, user_password, user_bio, user_image)"
, "VALUES ('"
, T.encodeUtf8 email
, "', '"
, T.encodeUtf8 username
, "', '"
, T.encodeUtf8 . getHashedPasswd $ hash
, "', ''"
, ", '');"
]
removeTestUser :: Text -> IO ()
removeTestUser username = do
@ -114,12 +116,13 @@ removeTestUser username = do
let password = Password $ T.append username "password"
hash <- hashPassword password
runSql $
sql $ mconcat
[ "DELETE FROM users "
, "WHERE user_username = '"
, T.encodeUtf8 username
, "';"
]
sql $
mconcat
[ "DELETE FROM users "
, "WHERE user_username = '"
, T.encodeUtf8 username
, "';"
]
registerNewUser :: forall st. Text -> THW.WaiSession st SResponse
registerNewUser username = do