├── Setup.hs ├── test └── Spec.hs ├── style-guide.org ├── src ├── main │ └── Main.hs └── Qwu │ ├── DB │ ├── Connect.hs │ ├── Util.hs │ ├── Test.hs │ ├── Query.hs │ ├── Table │ │ ├── Account.hs │ │ └── Post.hs │ └── Manipulation.hs │ ├── Html │ ├── NewPost.hs │ ├── Post.hs │ └── Base.hs │ └── Api │ └── Server.hs ├── stack.yaml ├── .gitignore ├── sql └── qwu.sql ├── LICENSE ├── notes.org ├── README.org └── qwu.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /style-guide.org: -------------------------------------------------------------------------------- 1 | * Style Guide 2 | 3 | ** Imports 4 | Order of imports: 5 | - Internal 6 | - =base= / GHC libraries 7 | - External 8 | 9 | Prefer unqualified imports unless there is an overlap. 10 | -------------------------------------------------------------------------------- /src/main/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Qwu.Api.Server 4 | 5 | import Network.Wai 6 | import Network.Wai.Handler.Warp 7 | 8 | main :: IO () 9 | main = run 8081 app 10 | 11 | -- main :: IO () 12 | -- main = putStrLn "hasdfd" 13 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | - location: 5 | git: git@github.com:bryangarza/uuid-aeson.git 6 | commit: 651ee914442e9a97693a2372c88576a4838e9df1 7 | extra-dep: true 8 | extra-deps: 9 | - servant-0.4.4.6 10 | - servant-lucid-0.4.4.6 11 | - servant-server-0.4.4.6 12 | - opaleye-0.4.2.0 13 | resolver: lts-5.4 14 | -------------------------------------------------------------------------------- /src/Qwu/DB/Connect.hs: -------------------------------------------------------------------------------- 1 | module Qwu.DB.Connect (pConnect) where 2 | 3 | import Database.PostgreSQL.Simple 4 | 5 | myConnectInfo :: ConnectInfo 6 | myConnectInfo = ConnectInfo 7 | { connectHost = "127.0.0.1" 8 | , connectPort = 5432 9 | , connectUser = "bryangarza" 10 | , connectPassword = "" 11 | , connectDatabase = "qwu" 12 | } 13 | 14 | pConnect :: IO Connection 15 | pConnect = connect myConnectInfo 16 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .hpc 10 | .hsenv 11 | .cabal-sandbox/ 12 | cabal.sandbox.config 13 | *.prof 14 | *.aux 15 | *.hp 16 | .stack-work/ 17 | /frontend/target 18 | /frontend/classes 19 | /frontend/checkouts 20 | /frontend/pom.xml 21 | /frontend/pom.xml.asc 22 | /frontend/*.jar 23 | /frontend/*.class 24 | /frontend/.lein-* 25 | /frontend/.nrepl-port 26 | /frontend/resources/public/js 27 | /frontend/out 28 | /frontend/.repl 29 | /frontend/*.log 30 | -------------------------------------------------------------------------------- /src/Qwu/Html/NewPost.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Qwu.Html.NewPost where 4 | 5 | import Control.Monad 6 | import Lucid 7 | 8 | newPost :: Monad m => HtmlT m () 9 | newPost = 10 | form_ [action_ "/newpost", method_ "post"] 11 | (div_ [class_ "newPostForm"] 12 | (do (textarea_ [name_ "msg" 13 | ,rows_ "10" 14 | ,cols_ "50"] 15 | "Write a new post") 16 | (div_ [class_ "button"] 17 | (button_ [type_ "submit"] "Submit!")))) 18 | -------------------------------------------------------------------------------- /sql/qwu.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE "accountTable" ( 2 | "accountId" UUID PRIMARY KEY, 3 | "username" TEXT NOT NULL, 4 | "email" TEXT NOT NULL, 5 | "password" TEXT NOT NULL 6 | ); 7 | 8 | CREATE TABLE "postTable" ( 9 | "postId" SERIAL PRIMARY KEY, 10 | "body" TEXT NOT NULL, 11 | "ts" TIMESTAMPTZ NOT NULL 12 | "accountId" UUID REFERENCES "accountTable" ON DELETE CASCADE, 13 | ); 14 | 15 | 16 | -- CREATE TABLE "accountPostTable" ( 17 | -- "postId" INT REFERENCES "postTable" ON DELETE CASCADE, 18 | -- "accountId" UUID REFERENCES "accountTable" ON DELETE CASCADE, 19 | -- PRIMARY KEY ("postId", "accountId") 20 | -- ); 21 | -------------------------------------------------------------------------------- /src/Qwu/DB/Util.hs: -------------------------------------------------------------------------------- 1 | module Qwu.DB.Util where 2 | 3 | import Qwu.DB.Connect 4 | 5 | import Crypto.PasswordStore (makePassword) 6 | import Data.Int (Int64) 7 | import Data.ByteString (ByteString) 8 | import Data.UUID (UUID) 9 | import Data.UUID.V4 (nextRandom) 10 | import Database.PostgreSQL.Simple (Connection, close) 11 | 12 | genUuid :: IO UUID 13 | genUuid = nextRandom 14 | 15 | genPassword :: ByteString -> IO ByteString 16 | genPassword x = makePassword x 18 17 | 18 | runWithConn :: (Connection -> t2 -> t3 -> IO Int64) -> t2 -> t3 -> IO () 19 | runWithConn action x y = 20 | do 21 | conn <- pConnect 22 | action conn x y 23 | close conn 24 | 25 | runWithConn3 :: (Connection -> t2 -> t3 -> t4 -> IO Int64) -> t2 -> t3 -> t4 -> IO () 26 | runWithConn3 action x y z = 27 | do 28 | conn <- pConnect 29 | action conn x y z 30 | close conn 31 | -------------------------------------------------------------------------------- /src/Qwu/Html/Post.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Qwu.Html.Post where 5 | 6 | import Qwu.DB.Table.Post 7 | import Qwu.Html.Base 8 | 9 | import Control.Lens (view) 10 | import Data.Text (pack) 11 | import Lucid 12 | 13 | -- HTML serialization of a single post 14 | instance ToHtml Post where 15 | toHtml post = 16 | li_ $ do 17 | div_ [class_ "post", id_ (pack . show $ view postId post)] $ do 18 | div_ [class_ "accountId"] (toHtml . show $ view accountId post) 19 | div_ [class_ "timestamp"] (toHtml . show $ view ts post) 20 | div_ [class_ "body"] (toHtml $ view body post) 21 | 22 | toHtmlRaw = toHtml 23 | 24 | -- HTML serialization of a list of posts 25 | instance ToHtml [Post] where 26 | toHtml posts = baseHtml . ul_ $ do 27 | foldMap toHtml posts 28 | 29 | toHtmlRaw = toHtml 30 | -------------------------------------------------------------------------------- /src/Qwu/Html/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Qwu.Html.Base where 4 | 5 | import Qwu.Html.NewPost 6 | 7 | import Control.Monad 8 | import Lucid 9 | 10 | container :: Monad m => HtmlT m () -> HtmlT m () 11 | container body = 12 | body_ (div_ [class_ "container"] 13 | (do h1_ "Qwu" 14 | div_ [class_ "posts"] body)) 15 | 16 | baseHtml :: Monad m => HtmlT m () -> HtmlT m () 17 | baseHtml body = 18 | doctypehtml_ 19 | (do head_ (do meta_ [charset_ "utf-8"] 20 | meta_ [name_ "viewport" 21 | ,content_ "width=device-width, initial-scale=1"] 22 | link_ [href_ "//fonts.googleapis.com/css?family=Open+Sans" 23 | ,rel_ "stylesheet" 24 | ,type_ "text/css"] 25 | link_ [href_ "//cdnjs.cloudflare.com/ajax/libs/twitter-bootstrap/3.1.0/css/bootstrap.min.css" 26 | ,rel_ "stylesheet" 27 | ,type_ "text/css"] 28 | title_ "Qwu") 29 | body_ (do newPost 30 | container body)) 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Bryan Garza 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /notes.org: -------------------------------------------------------------------------------- 1 | #+title: Notes 2 | 3 | * Postgres (psql) 4 | - ~CREATE DATABASE dbname (OWNER name);~ 5 | - ~\c(onnect) dbname~ 6 | - ~\i some/script.sql~ 7 | 8 | * Opaleye 9 | Type of ~runInsertReturning~ is: 10 | 11 | #+BEGIN_SRC haskell 12 | runInsertReturning :: Default QueryRunner returned haskells => 13 | Connection -> 14 | Table columnsW columnsR -> 15 | columnsW -> 16 | (columnsR -> returned) -> 17 | IO [haskells] 18 | #+END_SRC 19 | 20 | You have to write out the type of ~IO [haskells]~ (whether that be ~Int~, 21 | ~UUID~, whatever) so that the function can return a concrete type, otherwise it 22 | doesn't know what to return. 23 | 24 | ~[haskells]~ is the type var for what is returning... ~deckId~ is an ~Int~, so 25 | therefore we have ~IO [Int]~ as the return type. 26 | 27 | ~returned~ and ~haskells~ are constrained by the same typeclass, as they are 28 | representing the same exact 'thing' being returned. 29 | 30 | * Servant 31 | 32 | - [[https://github.com/haskell-servant/servant/issues/236][Example of writing instances of ~FromFormUrlEncoded~.]] 33 | -------------------------------------------------------------------------------- /src/Qwu/DB/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Qwu.DB.Test where 3 | 4 | import Qwu.DB.Manipulation 5 | import Qwu.DB.Table.Account 6 | import Qwu.DB.Table.Post 7 | 8 | import Data.Default 9 | import Data.Text 10 | import Data.UUID as U 11 | 12 | testCreatePost :: IO () 13 | testCreatePost = createPost (def :: Post) U.nil 14 | 15 | testUpdatePostBody :: PostId -> IO () 16 | testUpdatePostBody = updatePostBody "updated" 17 | 18 | testUpdateAccountUsername :: IO () 19 | testUpdateAccountUsername = updateAccountUsername "updatedUsername" U.nil 20 | 21 | testUpdateAccountEmail :: IO () 22 | testUpdateAccountEmail = updateAccountEmail "updatedEmail" U.nil 23 | 24 | testUpdateAccountPassword :: IO () 25 | testUpdateAccountPassword = updateAccountPassword "updatedPassword" U.nil 26 | 27 | testCreateAccount :: IO () 28 | testCreateAccount = createAccount (def :: Account) 29 | 30 | testWithAccount :: (UUID -> IO ()) -> String -> IO () 31 | testWithAccount action accountIdStr = 32 | case U.fromString accountIdStr of 33 | Just accountId -> action accountId 34 | Nothing -> action U.nil 35 | 36 | testDeleteAccount :: IO () 37 | testDeleteAccount = deleteAccount U.nil 38 | -------------------------------------------------------------------------------- /src/Qwu/DB/Query.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Qwu.DB.Query where 5 | 6 | import Qwu.DB.Connect 7 | import Qwu.DB.Table.Account (AccountId) 8 | import Qwu.DB.Table.Post 9 | 10 | import qualified Data.UUID as U 11 | import Data.UUID 12 | import Control.Arrow (returnA) 13 | import Control.Lens (view) 14 | import Data.Profunctor.Product.Default (Default) 15 | import Database.PostgreSQL.Simple (Connection) 16 | import Opaleye.PGTypes (pgUUID) 17 | import Opaleye 18 | ( Query 19 | , restrict 20 | , (.==) 21 | , queryTable 22 | , runQuery 23 | , showSqlForPostgres 24 | , Unpackspec ) 25 | 26 | postQuery :: Query ColumnR 27 | postQuery = queryTable table 28 | 29 | postByAccountId :: AccountId -> Query ColumnR 30 | postByAccountId idToMatch = proc () -> do 31 | row <- postQuery -< () 32 | restrict -< (view accountId row) .== pgUUID idToMatch 33 | returnA -< row 34 | 35 | runPostByAccountId :: IO [Post] 36 | runPostByAccountId = 37 | do 38 | conn <- pConnect 39 | runPostByAccountId' conn (postByAccountId U.nil) 40 | where runPostByAccountId' :: Connection -> Query ColumnR -> IO [Post] 41 | runPostByAccountId' = runQuery 42 | 43 | printSql :: Default Unpackspec a a => Query a -> IO () 44 | printSql = putStrLn . showSqlForPostgres 45 | -------------------------------------------------------------------------------- /src/Qwu/Api/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | module Qwu.Api.Server where 5 | 6 | import Qwu.DB.Manipulation 7 | import Qwu.DB.Query (runPostByAccountId) 8 | import qualified Qwu.DB.Table.Post as P 9 | import Qwu.Html.Post 10 | 11 | import Control.Lens (set, view) 12 | import Control.Monad.Trans (liftIO) 13 | import Control.Monad.Trans.Either (EitherT) 14 | import Data.Default 15 | import Data.UUID as U 16 | import Data.Text (Text) 17 | import Network.Wai (Application) 18 | import Network.Wai.Middleware.RequestLogger (logStdoutDev) 19 | import Servant 20 | import Servant.HTML.Lucid (HTML) 21 | 22 | type MyApi = "posts" :> Get '[JSON, HTML] [P.Post] 23 | -- Accept POST [(Text, Text)] (FormUrlEncoded), returns [Post] as JSON or HTML. 24 | :<|> "newpost" :> ReqBody '[FormUrlEncoded] [(Text, Text)] :> Post '[JSON, HTML] [P.Post] 25 | 26 | myApi :: Proxy MyApi 27 | myApi = Proxy 28 | 29 | server :: Server MyApi 30 | server = posts 31 | :<|> newpost 32 | where 33 | posts :: EitherT ServantErr IO [P.Post] 34 | posts = liftIO runPostByAccountId 35 | newpost :: [(Text, Text)] -> EitherT ServantErr IO [P.Post] 36 | newpost [(_, fieldData)] = do 37 | liftIO (createPost (set P.body fieldData (def :: P.Post)) U.nil) 38 | liftIO runPostByAccountId 39 | 40 | app :: Application 41 | app = logStdoutDev (serve myApi server) 42 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * qwu (twitter clone in haskell) 2 | - because why not. 3 | - ripped some parts of the db code from an unpublished project. 4 | - say hi [[https://twitter.com/bryangarza][@bryangarza]] 5 | 6 | 7 | ** status 8 | |------------+-------------| 9 | | layer | status | 10 | |------------+-------------| 11 | | db inserts | ✔ | 12 | | db deletes | ✔ | 13 | | db updates | ✔ | 14 | | db queries | in progress | 15 | |------------+-------------| 16 | | rest api | in progress | 17 | | frontend | in progress | 18 | |------------+-------------| 19 | 20 | ** important libraries 21 | - opaleye (postgres) 22 | - servant (api) 23 | - lucid (html edsl) 24 | - clay (css edsl) 25 | 26 | ** routes 27 | |---------------------+----------------------------+------+-------| 28 | | uri | desc | type | auth? | 29 | |---------------------+----------------------------+------+-------| 30 | | =/= | home | get | no | 31 | | =/= | username | get | no | 32 | | =/search/= | search for posts | get | no | 33 | | =//followers= | list a user's followers | get | no | 34 | | =//following= | list who user is following | get | no | 35 | | =/newpost= | new post | post | yes | 36 | | =/del//= | delete post by id | post | yes | 37 | | =/star/= | star a post by id | post | yes | 38 | | =/follow/= | follow a user | post | yes | 39 | | =/unfollow/= | unfollow a user | post | yes | 40 | |---------------------+----------------------------+------+-------| 41 | -------------------------------------------------------------------------------- /src/Qwu/DB/Table/Account.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Qwu.DB.Table.Account where 8 | 9 | import GHC.Generics 10 | import Control.Lens (makeLenses) 11 | import Data.Aeson 12 | import Data.Default 13 | import Data.Profunctor.Product.TH (makeAdaptorAndInstance) 14 | import Data.Text 15 | import Data.UUID as U 16 | import Data.UUID.Aeson 17 | import Opaleye 18 | ( Column 19 | , optional 20 | , PGText 21 | , PGUuid 22 | , required 23 | , Table(Table) ) 24 | 25 | type AccountId = UUID 26 | type Username = Text 27 | type Email = Text 28 | type Password = Text 29 | 30 | data Account' a b c d = Account 31 | { _accountId :: a 32 | , _username :: b 33 | , _email :: c 34 | , _password :: d 35 | } deriving (Eq, Show, Generic) 36 | 37 | makeLenses ''Account' 38 | 39 | type Account = Account' AccountId Username Email Password 40 | 41 | instance ToJSON Account 42 | 43 | instance Default Account where 44 | def = Account U.nil "foo" "foo@bar.com" "quux123456" 45 | 46 | $(makeAdaptorAndInstance "pAccount" ''Account') 47 | 48 | -- type signature format: 49 | -- someTable :: Table 50 | -- 51 | 52 | type ColumnW = Account' (Column PGUuid) (Column PGText) (Column PGText) (Column PGText) 53 | type ColumnR = Account' (Column PGUuid) (Column PGText) (Column PGText) (Column PGText) 54 | 55 | table :: Table ColumnW ColumnR 56 | table = Table "accountTable" ( 57 | pAccount Account { _accountId = required "accountId" 58 | , _username = required "username" 59 | , _email = required "email" 60 | , _password = required "password" }) 61 | -------------------------------------------------------------------------------- /src/Qwu/DB/Table/Post.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Qwu.DB.Table.Post where 8 | 9 | import Qwu.DB.Table.Account (AccountId) 10 | 11 | import GHC.Generics 12 | import Control.Lens (makeLenses) 13 | import Data.Aeson 14 | import Data.Default 15 | import Data.Profunctor.Product.TH (makeAdaptorAndInstance) 16 | import Data.Text 17 | import Data.Time (defaultTimeLocale, parseTimeM, UTCTime) 18 | import Data.UUID as U 19 | import Data.UUID.Aeson 20 | import Opaleye 21 | ( Column 22 | , optional 23 | , required 24 | , PGInt4 25 | , PGText 26 | , PGTimestamptz 27 | , PGUuid 28 | , Table(Table) ) 29 | 30 | type PostId = Int 31 | type Body = Text 32 | type Ts = UTCTime 33 | 34 | data Post' a b c d = Post 35 | { _postId :: a 36 | , _body :: b 37 | , _ts :: c 38 | , _accountId :: d 39 | } deriving (Eq, Show, Generic) 40 | 41 | makeLenses ''Post' 42 | 43 | type Post = Post' PostId Body Ts AccountId 44 | 45 | instance ToJSON Post 46 | 47 | instance Default Post where 48 | def = Post 0 "a post body" timestamp U.nil 49 | where 50 | Just timestamp = 51 | parseTimeM True defaultTimeLocale "%c" "Thu Jan 1 00:00:10 UTC 1970" :: Maybe UTCTime 52 | 53 | $(makeAdaptorAndInstance "pPost" ''Post') 54 | 55 | -- type signature format: 56 | -- someTable :: Table 57 | -- 58 | 59 | type ColumnW = Post' (Maybe (Column PGInt4)) (Column PGText) (Column PGTimestamptz) (Column PGUuid) 60 | type ColumnR = Post' (Column PGInt4) (Column PGText) (Column PGTimestamptz) (Column PGUuid) 61 | 62 | table :: Table ColumnW ColumnR 63 | table = Table "postTable" ( 64 | pPost Post { _postId = optional "postId" 65 | , _body = required "body" 66 | , _ts = required "ts" 67 | , _accountId = required "accountId" }) 68 | -------------------------------------------------------------------------------- /qwu.cabal: -------------------------------------------------------------------------------- 1 | name: qwu 2 | version: 0.1.0.0 3 | synopsis: Twitter clone 4 | description: Please see README.org 5 | homepage: http://github.com/bryangarza/qwu 6 | license: MIT 7 | license-file: LICENSE 8 | author: Bryan Garza 9 | maintainer: brygarza@gmail.com 10 | -- copyright: 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src/ 18 | exposed-modules: Qwu.Api.Server 19 | Qwu.DB.Connect 20 | Qwu.DB.Manipulation 21 | Qwu.DB.Query 22 | Qwu.DB.Test 23 | Qwu.DB.Util 24 | Qwu.DB.Table.Account 25 | Qwu.DB.Table.Post 26 | Qwu.Html.Base 27 | Qwu.Html.NewPost 28 | Qwu.Html.Post 29 | build-depends: base 30 | , aeson 31 | , bytestring 32 | , data-default 33 | , either 34 | , lens 35 | , lucid 36 | , mtl 37 | , opaleye 38 | , postgresql-simple 39 | , product-profunctors 40 | , pwstore-fast 41 | , servant 42 | , servant-lucid 43 | , servant-server 44 | , text 45 | , time 46 | , uuid 47 | , uuid-aeson 48 | , wai 49 | , wai-extra 50 | , warp 51 | default-language: Haskell2010 52 | 53 | executable qwu 54 | hs-source-dirs: src/main 55 | main-is: Main.hs 56 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 57 | build-depends: aeson 58 | , base 59 | , bytestring 60 | , data-default 61 | , either 62 | , lens 63 | , lucid 64 | , mtl 65 | , opaleye 66 | , postgresql-simple 67 | , product-profunctors 68 | , pwstore-fast 69 | , qwu 70 | , servant 71 | , servant-lucid 72 | , servant-server 73 | , text 74 | , time 75 | , uuid 76 | , uuid-aeson 77 | , wai 78 | , wai-extra 79 | , warp 80 | default-language: Haskell2010 81 | 82 | test-suite qwu-test 83 | type: exitcode-stdio-1.0 84 | hs-source-dirs: test 85 | main-is: Spec.hs 86 | build-depends: base 87 | , qwu 88 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 89 | default-language: Haskell2010 90 | 91 | source-repository head 92 | type: git 93 | location: https://github.com/bryangarza/qwu 94 | -------------------------------------------------------------------------------- /src/Qwu/DB/Manipulation.hs: -------------------------------------------------------------------------------- 1 | module Qwu.DB.Manipulation ( 2 | createPost 3 | , createAccount 4 | , deletePost 5 | , deleteAccount 6 | , updatePostBody 7 | , updateAccountUsername 8 | , updateAccountEmail 9 | , updateAccountPassword 10 | ) where 11 | 12 | import Qwu.DB.Table.Post 13 | import qualified Qwu.DB.Table.Post as Post 14 | import Qwu.DB.Table.Account 15 | import qualified Qwu.DB.Table.Account as Account 16 | import Qwu.DB.Util 17 | 18 | import Control.Lens (set, view) 19 | import Data.ByteString (ByteString) 20 | import Data.Text.Encoding (encodeUtf8, decodeUtf8) 21 | import Data.Time.Clock (getCurrentTime) 22 | import Opaleye 23 | ( (.==) 24 | , runDelete 25 | , runInsert 26 | , runUpdate 27 | ) 28 | import Opaleye.PGTypes 29 | ( pgStrictText 30 | , pgInt4 31 | , pgUUID 32 | , pgUTCTime ) 33 | 34 | createPost :: Post -> AccountId -> IO () 35 | createPost p accountId = 36 | do 37 | timestamp <- getCurrentTime 38 | runWithConn runInsert Post.table (columns timestamp) 39 | where 40 | body' = pgStrictText (view body p) 41 | accountId' = pgUUID accountId 42 | columns t = Post Nothing body' (pgUTCTime t) accountId' 43 | 44 | updatePostField :: (Post.ColumnW -> Post.ColumnW) -> PostId -> IO () 45 | updatePostField update idToMatch = 46 | runWithConn3 runUpdate Post.table update' match 47 | where 48 | idToMatch' = pgInt4 idToMatch 49 | update' = update . set postId (Just idToMatch') 50 | match = (.== idToMatch') . view postId 51 | 52 | updatePostBody :: Body -> PostId -> IO () 53 | updatePostBody = updatePostField . set body . pgStrictText 54 | 55 | deletePost :: PostId -> IO () 56 | deletePost idToMatch = runWithConn runDelete Post.table match 57 | where 58 | match = (.== pgInt4 idToMatch) . view postId 59 | 60 | createAccount :: Account -> IO () 61 | createAccount (Account accountId username email password) = 62 | do 63 | accountId <- genUuid 64 | hash <- genPassword (encodeUtf8 password) 65 | runWithConn runInsert Account.table (columns hash) 66 | where 67 | accountId' = pgUUID accountId 68 | username' = pgStrictText username 69 | email' = pgStrictText email 70 | columns hash = Account accountId' username' email' hash' 71 | where hash' = pgStrictText (decodeUtf8 hash) 72 | 73 | updateAccountField :: (Account.ColumnR -> Account.ColumnW) -> AccountId -> IO () 74 | updateAccountField update idToMatch = 75 | runWithConn3 runUpdate Account.table update match 76 | where 77 | match = (.== pgUUID idToMatch) . view Account.accountId 78 | 79 | updateAccountUsername :: Username -> AccountId -> IO () 80 | updateAccountUsername = updateAccountField . set username . pgStrictText 81 | 82 | updateAccountEmail :: Email -> AccountId -> IO () 83 | updateAccountEmail = updateAccountField . set email . pgStrictText 84 | 85 | updateAccountPassword :: Password -> AccountId -> IO () 86 | updateAccountPassword newPassword accountId = 87 | do 88 | hash <- genPassword (encodeUtf8 newPassword) 89 | updateAccountField (update hash) accountId 90 | where 91 | update :: ByteString -> Account.ColumnR -> Account.ColumnW 92 | update = set password . pgStrictText . decodeUtf8 93 | 94 | deleteAccount :: AccountId -> IO () 95 | deleteAccount idToMatch = runWithConn runDelete Account.table match 96 | where 97 | match = (.== pgUUID idToMatch) . view Account.accountId 98 | --------------------------------------------------------------------------------