diff options
Diffstat (limited to 'src/Server.hs')
-rw-r--r-- | src/Server.hs | 80 |
1 files changed, 40 insertions, 40 deletions
diff --git a/src/Server.hs b/src/Server.hs index 622b61b..45d2723 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,7 +1,6 @@ module Server -( - server -) where + ( server + ) where import Control.Exception.Base (bracket, catch, throwIO) import Data.Bits ((.|.)) @@ -12,60 +11,63 @@ 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 Database.MySQL.Base (ConnectInfo(connectOptions)) +import Database.MySQL.Base.Types (Option(ReadDefaultGroup)) import qualified Database.MySQL.Simple as MySQL -import Network.Socket (Family (AF_INET, AF_UNIX), - SockAddr (SockAddrInet, SockAddrUnix), Socket, - SocketOption (ReuseAddr), SocketType (Stream), bind, - close, getSocketName, inet_addr, listen, maxListenQueue, - setSocketOption, socket) -import Network.Wai.Handler.Warp (Port, defaultSettings, runSettingsSocket) +import Network.Socket + (Family(AF_INET, AF_UNIX), SockAddr(SockAddrInet, SockAddrUnix), + Socket, SocketOption(ReuseAddr), SocketType(Stream), bind, close, + getSocketName, inet_addr, listen, maxListenQueue, setSocketOption, + socket) +import Network.Wai.Handler.Warp + (Port, defaultSettings, runSettingsSocket) import System.IO (hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) -import System.Posix.Files (groupReadMode, groupWriteMode, ownerReadMode, - ownerWriteMode, removeLink, setFileMode, socketMode) +import System.Posix.Files + (groupReadMode, groupWriteMode, ownerReadMode, ownerWriteMode, + removeLink, setFileMode, socketMode) 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 ) + (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 + 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" - + 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 + setFileMode path $ + socketMode .|. ownerWriteMode .|. ownerReadMode .|. groupWriteMode .|. + groupReadMode hPutStrLn stderr $ "Listening on UNIX socket `" ++ path ++ "'" return sock createSocket (Left port) = do @@ -76,19 +78,17 @@ createSocket (Left port) = do 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 () - + _ -> return () removeIfExists :: FilePath -> IO () removeIfExists fileName = removeLink fileName `catch` handleExists - where handleExists e - | isDoesNotExistError e = return () - | otherwise = throwIO e - + where + handleExists e + | isDoesNotExistError e = return () + | otherwise = throwIO e |