Version 0.0.1

1 files changed, 78 insertions, 0 deletions

diff --git a/src/Server.hs b/src/Server.hs
new file mode 100644
index 0000000..3ecb642
--- /dev/null
+++ b/src/Server.hs
@@ -0,0 +1,78 @@
+module Server
+(
+  server
+) where
+
+import Control.Exception.Base (throwIO, catch, bracket)
+import Data.Bits ((.|.))
+import Data.Pool (createPool, destroyAllResources)
+import Database.MySQL.Base (ConnectInfo)
+import Network.Socket (socket, bind, listen, close, maxListenQueue,
+                       getSocketName, inet_addr,
+                       Family(AF_UNIX, AF_INET), SocketType(Stream),
+                       Socket, SockAddr(SockAddrUnix, SockAddrInet))
+import Network.Wai.Handler.Warp (Port, defaultSettings, runSettingsSocket)
+import System.IO (hPutStrLn, stderr)
+import System.IO.Error (isDoesNotExistError)
+import System.Posix.Files (removeLink, setFileMode, socketMode,
+                           ownerReadMode, ownerWriteMode, groupReadMode, groupWriteMode)
+import qualified Database.MySQL.Simple as MySQL
+
+import Application (app)
+
+type Listen = Either Port FilePath
+
+
+server :: Listen -> ConnectInfo -> IO ()
+server socketSpec mysqlConnInfo =
+  bracket
+    ( do
+      sock <- createSocket socketSpec
+      mysql <- createPool
+                (MySQL.connect mysqlConnInfo)
+                MySQL.close
+                1 -- stripes
+                60 -- keep alive (seconds)
+                10 -- max connections
+      return (sock, mysql) )
+    ( \(sock, mysql) -> do
+      closeSocket sock
+      destroyAllResources mysql )
+    ( \(sock, mysql) -> do
+      listen sock maxListenQueue
+      runSettingsSocket defaultSettings sock (app mysql) )
+
+
+createSocket :: Listen -> IO Socket
+createSocket (Right path) = do
+  removeIfExists path
+  sock <- socket AF_UNIX Stream 0
+  bind sock $ SockAddrUnix path
+  setFileMode path $ socketMode
+                  .|. ownerWriteMode .|. ownerReadMode
+                  .|. groupWriteMode .|. groupReadMode
+  hPutStrLn stderr $ "Listening on UNIX socket `" ++ path ++ "'"
+  return sock
+createSocket (Left port) = do
+  sock <- socket AF_INET Stream 0
+  addr <- inet_addr "127.0.0.1"
+  bind sock $ SockAddrInet (fromIntegral port) addr
+  hPutStrLn stderr $ "Listening on localhost:" ++ show port
+  return sock
+
+
+closeSocket :: Socket -> IO ()
+closeSocket sock = do
+  name <- getSocketName sock
+  close sock
+  case name of
+    SockAddrUnix path -> removeIfExists path
+    _ -> return ()
+
+
+removeIfExists :: FilePath -> IO ()
+removeIfExists fileName = removeLink fileName `catch` handleExists
+  where handleExists e
+          | isDoesNotExistError e = return ()
+          | otherwise = throwIO e
+