1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
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
|
