Commit 2bbc108f authored by Ibnu Daru Aji's avatar Ibnu Daru Aji

finished create postArticleCreateCoach.

parent 0b2f050b
......@@ -47,6 +47,7 @@ library
, persistent >= 2.8
, persistent-postgresql >= 2.8
, persistent-template >= 2.5
, random >= 1.1
, regex-compat >= 0.95
, servant-auth
, servant-auth-client
......
......@@ -71,6 +71,7 @@ articlesApi authres =
getArticlesCoach authres
:<|> getArticlesFeed authres
:<|> getArticleSlugCoach authres
:<|> postArticleCreateCoach authres
:<|> panic ""
articlesServer :: Configuration -> AuthResult User -> Server ArticlesAPI
......
......@@ -4,9 +4,11 @@ module Coach.Articles where
import Lib.Prelude
import qualified Data.Text as T
import Database.Esqueleto hiding (isNothing)
import Servant
import Servant.Auth.Server
import System.Random
import Conf
import Model
......@@ -112,3 +114,36 @@ resultQueryToResponseArticle (entarticle, entauthor, vtags, vfavcounts, vfaving,
isfavoriting
favcounts $
ResponseProfileBody userUsername userBio userImage isfollowing
postArticleCreateCoach ::
MonadIO m
=> AuthResult User
-> RequestCreateArticle
-> CoachT m ResponseArticle
postArticleCreateCoach (Authenticated user) (RequestCreateArticle RequestCreateArticleBody {..}) = do
randgen <- liftIO newStdGen
let appendage = T.pack $ take 10 $ randomRs ('a', 'z') randgen
slug = titleDescToSlug reqcrtarticlTitle reqcrtarticlDescription appendage
liftIO $ print reqcrtarticlTagList
articles <-
runDb $ do
insertArticle
(userUsername user)
slug
reqcrtarticlTitle
reqcrtarticlDescription
reqcrtarticlBody
upsertMaybeTags reqcrtarticlTagList slug
selectArticles
(Just $ userUsername user)
False
(Just slug)
Nothing
Nothing
Nothing
1
0
case articles of
[] -> throwError err404 {errBody = "No such article."}
x:_ -> return $ ResponseArticle $ resultQueryToResponseArticle x
postArticleCreateCoach _ _ = throwError err401
......@@ -8,10 +8,12 @@ import Lib.Prelude
import Database.Persist.Postgresql
import Servant
import Servant.Auth.Server
import System.Random
data Configuration = Configuration
{ configurationPool :: ConnectionPool
, configurationJWTSettings :: JWTSettings
, configurationRandomGen :: StdGen
}
newtype CoachT m a = CoachT
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Que.Articles where
import Lib.Prelude hiding (from, get, on,
(<&>))
import Data.Time
import Database.Esqueleto
import Database.Esqueleto.Internal.Language
import Database.Esqueleto.PostgreSQL
......@@ -132,3 +136,52 @@ subscribedAuthorQuery username = do
where_ $ user ^. UserUsername ==. val username
return $ author ^. UserId
insertArticle ::
( PersistUniqueWrite backend
, PersistQueryWrite backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Text
-> Text
-> Text
-> Text
-> Text
-> ReaderT backend m ()
insertArticle username slug title descrip body = do
now <- liftIO getCurrentTime
insertSelect $
from $ \user -> do
where_ (user ^. UserUsername ==. val username)
return $
Article
<# val slug
<&> (user ^. UserId)
<&> val title
<&> val descrip
<&> val body
<&> val now
<&> nothing
upsertMaybeTags ::
( BaseBackend backend ~ SqlBackend
, PersistQueryWrite backend
, BackendCompatible SqlBackend backend
, PersistUniqueWrite backend
, MonadIO m
)
=> Maybe [Text]
-> Text
-> ReaderT backend m ()
upsertMaybeTags Nothing _ = return ()
upsertMaybeTags (Just tags) slug = do
putMany $ map Tag tags
insertSelect $
from $ \(article, tag) -> do
where_ $ article ^. ArticleSlug ==. val slug
where_ $ tag ^. TagName `in_` valList tags
return $
Tagged
<# (article ^. ArticleId)
<&> (tag ^. TagId)
......@@ -14,6 +14,7 @@ import Network.Wai.Handler.Warp (Port)
import Servant
import Servant.Auth
import Servant.Auth.Server
import System.Random
import Conf
import Model
......@@ -55,9 +56,10 @@ running :: IO ()
running = do
jwk <- generateKey
pool <- runStderrLoggingT (createPostgresqlPool connstring 10)
rand <- newStdGen
let jws = defaultJWTSettings jwk
cfg = defaultCookieSettings :. jws :. EmptyContext
conf = Configuration pool jws
conf = Configuration pool jws rand
runSqlPool doMigration pool
run 8080 (serveWithContext conduitProxy cfg (conduitServer conf))
......@@ -68,8 +70,9 @@ startDevel :: IO (Port, Application)
startDevel = do
jwk <- generateKey
pool <- runStderrLoggingT (createPostgresqlPool connstring 10)
rand <- newStdGen
let jws = defaultJWTSettings jwk
cfg = defaultCookieSettings :. jws :. EmptyContext
conf = Configuration pool jws
conf = Configuration pool jws rand
runSqlPool doMigration pool
return (8080, serveWithContext conduitProxy cfg (conduitServer conf))
......@@ -3,16 +3,17 @@ module Util where
import Lib.Prelude
import Crypto.BCrypt
import Data.ByteString.Char8 (pack)
import Data.Text (unpack)
import qualified Data.ByteString.Char8 as BC (pack)
import Data.Text (pack, toLower, unpack)
import Servant.Auth.Server
import Text.Regex
generatePassword :: Text -> IO Text
generatePassword password = do
mpass <-
hashPasswordUsingPolicy
slowerBcryptHashingPolicy
(pack $ unpack password)
(BC.pack $ unpack password)
case mpass of
Nothing -> generatePassword password
Just pa -> return (decodeUtf8 pa)
......@@ -20,3 +21,10 @@ generatePassword password = do
authresToMaybe :: AuthResult a -> Maybe a
authresToMaybe (Authenticated x) = Just x
authresToMaybe _ = Nothing
titleDescToSlug :: Text -> Text -> Text -> Text
titleDescToSlug title desc appendage =
smaller title <> "-" <> smaller desc <> "-" <> smaller appendage
where
smaller sentence =
toLower (pack (subRegex (mkRegex "[^a-zA-Z0-9_.]") (unpack sentence) "-"))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment