Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
338 lines (274 sloc) 12.2 KB
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import Control.Exception (SomeException)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Foldable (traverse_)
import Data.Text (Text)
import Data.Proxy (Proxy(..))
import Data.Word (Word16)
import GHC.Generics (Generic)
import Options.Generic (ParseRecord)
import Prelude hiding (id)
import Database.PostgreSQL.Simple (FromRow, Only(..), Query, ToRow, (:.)(..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Servant.HTML.Blaze (HTML)
import Servant.Server (Handler)
import Text.Blaze (Markup, (!))
import Text.Blaze.Html5 (AttributeValue)
import Web.HttpApiData (FromHttpApiData)
import Web.FormUrlEncoded (FromForm)
import Servant.API
( FormUrlEncoded
, Get
, Post
, QueryParam'
, ReqBody
, Required
, Strict
, (:>)
, (:<|>)(..)
)
import qualified Control.Exception as Exception
import qualified Control.Monad as Monad
import qualified Control.Monad.Catch as Catch
import qualified Database.PostgreSQL.Simple as PostgreSQL
import qualified Network.Wai.Handler.Warp as Warp
import qualified Options.Generic as Options
import qualified Servant.Server as Server
import qualified Text.Blaze.Html5 as Html
import qualified Text.Blaze.Html5.Attributes as Attr
newtype Options = Options { connectPort :: Word16 }
deriving stock (Generic)
deriving anyclass (ParseRecord)
newtype User = User { name :: Text }
deriving stock (Generic)
deriving anyclass (FromForm, FromRow, ToRow)
deriving newtype (FromHttpApiData)
data Follow = Follow { follower :: Text, followed :: Text }
deriving stock (Generic)
deriving anyclass (FromForm, ToRow)
data Tweet = Tweet { name :: Text, contents :: Text }
deriving stock (Generic)
deriving anyclass (FromForm, FromRow)
type API =
Get '[HTML] Markup
:<|> "user" :> ReqBody '[FormUrlEncoded] User :> Post '[HTML] Markup
:<|> "user" :> QueryParam' '[Required, Strict] "name" User :> Get '[HTML] Markup
:<|> "user" :> "delete" :> ReqBody '[FormUrlEncoded] User :> Post '[HTML] Markup
:<|> "users" :> Get '[HTML] Markup
:<|> "tweet" :> ReqBody '[FormUrlEncoded] Tweet :> Post '[HTML] Markup
:<|> "follow" :> ReqBody '[FormUrlEncoded] Follow :> Post '[HTML] Markup
main :: IO ()
main = do
Options {..} <- Options.getRecord "Simple Twitter"
let connectInfo =
PostgreSQL.defaultConnectInfo
{ PostgreSQL.connectPort = connectPort
, PostgreSQL.connectHost = ""
}
let open = PostgreSQL.connect connectInfo
let close = PostgreSQL.close
Exception.bracket open close \connection -> do
let execute :: (MonadIO io, ToRow input) => input -> Query -> io ()
execute input q = liftIO do
_ <- PostgreSQL.execute connection q input
return ()
let query
:: (MonadIO io, ToRow input, FromRow output)
=> input -> Query -> io [output]
query input q = liftIO (PostgreSQL.query connection q input)
let query_
:: (MonadIO io, FromRow output)
=> Query -> io [output]
query_ q = liftIO (PostgreSQL.query_ connection q)
let submit label =
Html.button
! Attr.type_ "submit"
! Attr.class_ "btn btn-primary btn-sm"
$ label
let field :: AttributeValue -> Markup
field name = do
Html.div ! Attr.class_ "form-group" $ do
Html.input
! Attr.type_ "text"
! Attr.class_ "form-control form-control-sm"
! Attr.name name
! Attr.placeholder name
let form action method html =
Html.div ! Attr.class_ "col-md-4" $ do
Html.form
! Attr.action action
! Attr.method method
! Attr.class_ "border m-3 p-2 bg-light"
$ html
let forms :: Markup
forms = do
Html.div ! Attr.class_ "row" $ do
form "/" "get" do
submit "Global timeline"
Html.div ! Attr.class_ "row" $ do
form "/user" "post" do
field "name"
submit "Create user"
form "/user/delete" "post" do
field "name"
submit "Delete user"
form "/users" "get" do
submit "Get users"
Html.div ! Attr.class_ "row" $ do
form "/tweet" "post" do
field "name"
field "contents"
submit "Create tweet"
form "/follow" "post" do
field "follower"
field "followed"
submit "Follow"
form "/user" "get" do
field "name"
submit "Get user"
let ul html = Html.ul ! Attr.class_ "list-group" $ html
let li html = Html.li ! Attr.class_ "list-group-item" $ html
let wrap :: Markup -> Markup
wrap body =
Html.html do
Html.head do
Html.title "Simple Twitter"
Html.link
! Attr.rel "stylesheet"
! Attr.href "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css"
Html.body do
Html.h1
! Attr.class_ "display-4 text-center"
$ "Simple Twitter"
Html.div ! Attr.class_ "container" $ do
Html.div ! Attr.class_ "row" $ do
Html.div ! Attr.class_ "col-md-6" $ forms
Html.div ! Attr.class_ "col-md-6" $ body
let failWith :: Text -> Handler Markup -> Handler Markup
failWith message handler = do
let fallback :: SomeException -> Handler Markup
fallback _ = return (wrap (Html.toHtml message))
Catch.handle fallback handler
let index :: Handler Markup
index = do
tweets <- query_ [sql|
SELECT "user".name, tweet.contents
FROM "user"
INNER JOIN user_tweet ON "user".name = user_tweet."user"
INNER JOIN tweet ON user_tweet.tweet = tweet.id
ORDER BY tweet.time DESC
|]
let renderTweet (Tweet {..}) =
li (Html.toHtml (name <> ": " <> contents))
return do
wrap (ul (traverse_ renderTweet tweets))
let getUsers :: Handler Markup
getUsers = do
users <- query_ [sql|SELECT name FROM "user"|]
let renderUser (User {..}) = li (Html.toHtml name)
return (wrap (ul (traverse_ renderUser users)))
let createUser :: User -> Handler Markup
createUser user@User{..} = do
let message =
"A user named '" <> name <> "' already exists"
failWith message do
execute user [sql|INSERT INTO "user" (name) VALUES (?)|]
getUsers
let getUser :: User -> Handler Markup
getUser user@User{..} = do
let message =
"No user named '" <> name <> "' exists"
failWith message do
followeds <- query user [sql|
SELECT follows.followed
FROM "user"
INNER JOIN follows ON "user".name = follows.follower
WHERE "user".name = ?
|]
history <- query user [sql|
SELECT "user".name, tweet.contents
FROM "user"
INNER JOIN user_tweet ON "user".name = user_tweet."user"
INNER JOIN tweet ON user_tweet.tweet = tweet.id
WHERE "user".name = ?
ORDER BY tweet.time DESC
|]
timeline <- query user [sql|
SELECT follows.followed, tweet.contents
FROM "user"
INNER JOIN follows ON "user".name = follows.follower
INNER JOIN user_tweet ON follows.followed = user_tweet."user"
INNER JOIN tweet ON user_tweet.tweet = tweet.id
WHERE "user".name = ?
ORDER BY tweet.time DESC
|]
let renderHistory (Tweet { contents }) =
li (Html.toHtml contents)
let renderTimeline (Tweet { name = followed, ..}) =
li (Html.toHtml (followed <> ": " <> contents))
let renderUser (User { name = followed }) =
li (Html.toHtml followed)
return do
wrap do
Html.h2 (Html.toHtml name)
Html.hr
Monad.when (not (null history)) do
Html.h3 "History"
ul (traverse_ renderHistory history)
Monad.when (not (null timeline)) do
Html.h3 "Timeline"
ul (traverse_ renderTimeline timeline)
Monad.when (not (null followeds)) do
Html.h3 "Follows"
ul (traverse_ renderUser followeds)
let deleteUser :: User -> Handler Markup
deleteUser user@User{..}= do
let message =
"No user named '" <> name <> "' exists"
failWith message do
execute user [sql|DELETE FROM "user" WHERE name = ?|]
getUsers
let createTweet :: Tweet -> Handler Markup
createTweet (Tweet {..}) = do
rows <- query (Only contents) [sql|
INSERT INTO tweet (contents) VALUES (?) RETURNING (id)
|]
id <- case rows of
[ (id :: Only Integer) ] -> return id
_ -> Catch.throwM Server.err500
execute (Only name :. id) [sql|
INSERT INTO user_tweet ("user", tweet) VALUES (?, ?)
|]
getUser (User {..})
let follow :: Follow -> Handler Markup
follow f@Follow{..} = do
let message =
"'" <> follower <> "' already follows '" <> followed <> "'"
failWith message do
execute f [sql|
INSERT INTO follows (follower, followed) VALUES (?, ?)
|]
getUser (User { name = follower })
let server = index
:<|> createUser
:<|> getUser
:<|> deleteUser
:<|> getUsers
:<|> createTweet
:<|> follow
let application = Server.serve @API Proxy server
Warp.run 80 application
You can’t perform that action at this time.