From 36da990afc3f9c5b1c4ce95e45821b2f13e169e5 Mon Sep 17 00:00:00 2001
From: Johannes Schilling <dario@deaktualisierung.org>
Date: Mon, 4 Jan 2016 18:40:25 +0100
Subject: [PATCH] implement first part of database stuff
---
myOwnPad.cabal | 3 ++
server/Server.hs | 8 ++-
src/Pad/DB.hs | 128 +++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 138 insertions(+), 1 deletion(-)
create mode 100644 src/Pad/DB.hs
diff --git a/myOwnPad.cabal b/myOwnPad.cabal
index 43a21e8..8c8f86a 100644
--- a/myOwnPad.cabal
+++ b/myOwnPad.cabal
@@ -17,6 +17,7 @@ library
Pad.NetProtocol.Types
Pad.NetProtocol.Instances
Pad.NetProtocol.Parse
+ Pad.DB
default-language: Haskell2010
other-extensions:
InstanceSigs
@@ -27,6 +28,7 @@ library
, attoparsec
, word8
, time
+ , postgresql-simple
executable myOwnPad-server
hs-source-dirs: server
@@ -46,6 +48,7 @@ executable myOwnPad-server
, wai-websockets
, warp
ghc-options: -O3 -threaded
+ , postgresql-simple
executable myOwnPad-client
hs-source-dirs: client
diff --git a/server/Server.hs b/server/Server.hs
index e44b84a..8810453 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -19,14 +19,17 @@ import System.Directory
import Control.Concurrent
import Control.Exception
+import Database.PostgreSQL.Simple as PSQL hiding (connect)
+
import Pad.NetProtocol
import Pad.NetProtocol.Types
import Pad.NetProtocol.Instances
import Pad.NetProtocol.Parse
-import Pad.Server.Types
+import Pad.Server.Types hiding (PadId(..))
+import Pad.DB
-- idee: websockets können kein "remote addr" -> wie identifizieren?
-- -> im http-teil ne ID generieren und dem client als protocol geben
@@ -40,6 +43,9 @@ import Pad.Server.Types
main :: IO ()
main = do
+ sqlConn <- connect -- TODO: config is hardcoded in Pad.DB
+ --createInitialTables sqlConn
+
eventloopChan <- newChan :: IO (Chan PadMessage)
let app = WAI.websocketsOr WS.defaultConnectionOptions (wsApp eventloopChan) httpApp
forkIO $ eventloop eventloopChan []
diff --git a/src/Pad/DB.hs b/src/Pad/DB.hs
new file mode 100644
index 0000000..868f6b8
--- /dev/null
+++ b/src/Pad/DB.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+module Pad.DB where
+
+
+import Database.PostgreSQL.Simple
+import Database.PostgreSQL.Simple.FromRow
+import Database.PostgreSQL.Simple.ToRow
+import Database.PostgreSQL.Simple.FromField
+import Database.PostgreSQL.Simple.ToField
+
+import Data.Time.LocalTime
+import qualified Data.ByteString as BS
+
+
+-- for the Eq ZonedTime instance
+import Pad.NetProtocol.Instances
+
+-- TODO: make this configurable ..
+dbConnString :: BS.ByteString
+dbConnString = "user=pad dbname=pad password=iRnwYqr3ENjki"
+
+connect :: IO Connection
+connect = connectPostgreSQL dbConnString
+
+
+
+{-
+ - evtl. is des eigentlich ne blöde idee des hier zu machen.. sollen
+ - leute gfälligst getan haben bzw. share/setupdb.sh verwenden
+ - --}
+createInitialTables :: Connection -> IO ()
+createInitialTables conn = withTransaction conn $ do
+ -- the type annotation is just so that there's no ambiguity and i
+ -- don't have to create an instance
+ conn `execute_` "CREATE TABLE PAD_CREATE_LOCK(\
+ \pad_name VARCHAR PRIMARY KEY,\
+ \remote_addr VARCHAR,\
+ \client_id VARCHAR,\
+ \lock_start TIMESTAMPTZ)"
+ -- TODO: autoremove (timestamp/date, mode)
+ conn `execute_` "CREATE TABLE PAD(\
+ \id SERIAL PRIMARY KEY,\
+ \name VARCHAR NOT NULL UNIQUE,\
+ \latest_rev INTEGER NOT NULL,\
+ \password VARCHAR,\
+ \ctime TIMESTAMPTZ NOT NULL,\
+ \atime TIMESTAMPTZ NOT NULL)"
+ conn `execute_` "CREATE INDEX ON PAD (name)"
+ return ()
+
+
+newtype PadId = PadId BS.ByteString deriving (Show, Eq)
+newtype ClientAddr = ClientAddr BS.ByteString deriving (Show, Eq)
+newtype ClientId = ClientId BS.ByteString deriving (Show, Eq)
+
+data PadCreationLock = PadCreationLock PadId ClientAddr ClientId ZonedTime deriving (Show, Eq)
+
+
+-- hs -> psql for struct fields
+instance FromField PadId where
+ fromField f bs = PadId <$> fromField f bs
+
+-- psql -> hs for struct fields
+instance ToField PadId where
+ toField (PadId bs) = toField bs
+
+instance FromField ClientAddr where
+ fromField f bs = ClientAddr <$> fromField f bs
+instance ToField ClientAddr where
+ toField (ClientAddr bs) = toField bs
+
+instance FromField ClientId where
+ fromField f bs = ClientId <$> fromField f bs
+instance ToField ClientId where
+ toField (ClientId bs) = toField bs
+
+
+-- hs -> psql for structs
+instance ToRow PadCreationLock where
+ toRow (PadCreationLock pi ca ci ts) = [toField pi, toField ca, toField ci, toField ts]
+
+-- psql -> hs for structs
+instance FromRow PadCreationLock where
+ fromRow = PadCreationLock <$> field <*> field <*> field <*> field
+
+
+{- the semantics of this is as follows:
+ - 1. client connects to /p/<padid>
+ - 2. if this is the first time anyone tried that padid, the client is
+ - shown the pad-creation(password, public, timeout)-dialogue
+ - 3. when showing that dialogue, the client has a 2-minute "lock" on
+ - that padid, meaning other clients that try this padid will get a
+ - information-page telling them to wait for creation
+ - 4. the lock is cleared in the pad creation transaction
+ -
+ - if the pad already exists, returns 'Nothing'
+ - otherwise returns the acquired lock object
+ - --}
+getCreationLock :: Connection -> PadId -> IO (Maybe PadCreationLock)
+getCreationLock conn padId = do
+ print "getCreationLock"
+ print padId
+
+ withTransaction conn $ do
+ [Only (n :: Integer)] <- query conn "SELECT COUNT(*) FROM pad WHERE name=?" [padId]
+ -- while we're at it..
+ execute_ conn "DELETE FROM pad_create_lock WHERE current_timestamp - lock_start > interval '00:02:00'"
+ case n of
+ 0 -> do
+ print "doesn't exist yet, checking creation lock"
+ (lock_exists :: [PadCreationLock]) <- query conn "SELECT * FROM pad_create_lock WHERE pad_name=?" (Only padId)
+
+ case lock_exists of
+ [] -> do
+ print "doesn't exist yet, building creation lock"
+ [lock] <- query conn "INSERT INTO pad_create_lock (pad_name, lock_start, client_id, remote_addr) VALUES (?, current_timestamp, ?, ?) RETURNING *" (padId, ("cid" :: BS.ByteString), ("rar" :: BS.ByteString))
+ return $ Just lock
+ [lock@(PadCreationLock pi ca ci ts)] -> do
+ print $ "exists already, held by " ++ (show ci)
+ return $ Just lock
+ 1 -> do
+ print "exists, returning 'Nothing'"
+ return Nothing
+ _ -> do
+ print $ "n too large(" ++ show n ++ "), something went wrong"
+ return Nothing
+
+ return Nothing
--
GitLab