module Server ( server ) where import Control.Exception.Base (throwIO, catch, bracket) import Data.Bits ((.|.)) import Data.List (find) import Data.Maybe (fromJust) import Data.Pool (createPool, destroyAllResources) import Data.Text.Lazy (Text) import Data.Text.Lazy.Encoding (decodeUtf8) import Database.MySQL.Base (ConnectInfo(connectOptions)) import Database.MySQL.Base.Types (Option(ReadDefaultGroup)) import Network.Socket (socket, setSocketOption, bind, listen, close, maxListenQueue, getSocketName, inet_addr, Family(AF_UNIX, AF_INET), SocketType(Stream), SocketOption(ReuseAddr), 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 Data.ByteString.Lazy as LBS import qualified Data.HashMap.Lazy as HM import qualified Database.MySQL.Simple as MySQL import Application (app) type Listen = Either Port FilePath server :: Listen -> [ConnectInfo] -> FilePath -> IO () server socketSpec mysqlConnInfo dataDir = bracket ( do sock <- createSocket socketSpec mysql <- HM.fromList <$> mapM (\c -> do p <- createPool (MySQL.connect c) MySQL.close 1 60 10 return (getGroup c, p)) mysqlConnInfo return (sock, mysql) ) ( \(sock, mysql) -> do closeSocket sock mapM_ destroyAllResources $ HM.elems mysql ) ( \(sock, mysql) -> do listen sock maxListenQueue hPutStrLn stderr $ "Static files from `" ++ dataDir ++ "'" runSettingsSocket defaultSettings sock =<< app mysql dataDir) getGroup :: ConnectInfo -> Text getGroup = decodeUtf8 . getName . fromJust . find isGroup . connectOptions where isGroup (ReadDefaultGroup _) = True isGroup _ = False -- FIXME: Removing trailing zero added for buggy mysql in Main.hs. getName (ReadDefaultGroup n) = LBS.takeWhile (0 /=) . LBS.fromStrict $ n getName _ = error "Cannot happen" 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 setSocketOption sock ReuseAddr 1 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