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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
module Server
( Listen(..)
, server
) where
import Control.Exception.Base (bracket, catch, throwIO)
import Data.Bits ((.|.))
import Data.Pool (createPool, destroyAllResources)
import Database.MySQL.Base (ConnectInfo)
import qualified Database.MySQL.Simple as MySQL
import Network.Socket
( AddrInfoFlag(AI_NUMERICSERV)
, Family(AF_UNIX)
, SockAddr(SockAddrUnix)
, Socket
, SocketOption(ReuseAddr)
, SocketType(Stream)
, addrAddress
, addrFamily
, addrFlags
, addrProtocol
, addrSocketType
, bind
, close
, defaultHints
, getAddrInfo
, getSocketName
, listen
, maxListenQueue
, setSocketOption
, socket
)
import Network.Wai.Handler.Warp (defaultSettings, runSettingsSocket)
import System.IO (hPutStrLn, stderr)
import System.IO.Error (isDoesNotExistError)
import System.Posix.Files
( groupReadMode
, groupWriteMode
, ownerReadMode
, ownerWriteMode
, removeLink
, setFileMode
, socketMode
)
import Application (app)
data Listen
= Socket FilePath
| Port Int
server :: Listen -> ConnectInfo -> FilePath -> IO ()
server socketSpec mysqlConnInfo dataDir =
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
hPutStrLn stderr $ "Static files from `" ++ dataDir ++ "'"
runSettingsSocket defaultSettings sock =<< app mysql dataDir)
createSocket :: Listen -> IO Socket
createSocket (Socket 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 (Port port) = do
addr:_ <- getAddrInfo (Just hints) (Just "localhost") (Just svc)
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
setSocketOption sock ReuseAddr 1
bind sock $ addrAddress addr
hPutStrLn stderr $ "Listening on localhost:" ++ show port
return sock
where
svc = show port
hints = defaultHints {addrFlags = [AI_NUMERICSERV], addrSocketType = Stream}
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
|
