carlos / todomvc-bakeoff Public

Download this file

1	-- | @todo-haskell --socket <path> --db <path>@ on Carloku, or
2	-- @todo-haskell --listen 127.0.0.1:<port> --db <path>@ locally.
3	module Main (main) where
4
5	import Control.Exception (bracket, catch, throwIO)
6	import Control.Monad (forM_, unless)
7	import Data.ByteString.Char8 qualified as B8
8	import Data.Text qualified as T
9	import Data.Word (Word8)
10	import Network.Socket
11	import Network.Wai.Handler.Warp
12	import System.Environment (getArgs, lookupEnv)
13	import System.Exit (exitWith, ExitCode (..))
14	import System.IO (hPutStrLn, stderr)
15	import System.IO.Error (isDoesNotExistError)
16	import System.Posix.Files (removeLink)
17	import System.Posix.Signals (Handler (CatchOnce), installHandler, sigINT, sigTERM)
18	import Text.Read (readMaybe)
19
20	import Todo.App
21	import Todo.Db qualified as Db
22
23	data Bind
24	= UnixSocket FilePath
25	| Loopback (Word8, Word8, Word8, Word8) PortNumber
26
27	data Options = Options
28	{ optBind :: Maybe Bind
29	, optDb :: Maybe FilePath
30	}
31
32	main :: IO ()
33	main = do
34	args <- getArgs
35	(target, dbPath) <- case parseArgs args (Options Nothing Nothing) of
36	Right (Options (Just b) (Just d)) -> pure (b, d)
37	Right _ -> usage "both --db and one of --socket or --listen are required"
38	Left err -> usage err
39	host <- lookupEnv "CARLOS_HOST"
40	let config = case target of
41	-- On Carloku the edge serves https://$CARLOS_HOST.
42	UnixSocket _ -> Config (B8.pack . ("https://" <>) <$> host) True
43	Loopback addr port -> Config (Just (B8.pack ("http://" <> showAddr addr port))) False
44	bracket (Db.open dbPath) Db.close $ \db ->
45	bracket (listenOn target) (cleanUp target) $ \sock -> do
46	hPutStrLn stderr ("todo-haskell " <> T.unpack version <> " listening on " <> describe target)
47	runSettingsSocket settings sock (app config db)
48	hPutStrLn stderr "todo-haskell stopped"
49
50	-- | Warp closes the listening socket on SIGTERM or SIGINT, lets requests
51	-- in flight finish (for up to five seconds), and then 'runSettingsSocket'
52	-- returns, so 'main' closes the database and exits 0.
53	settings :: Settings
54	settings =
55	setInstallShutdownHandler onSignal
56	. setGracefulShutdownTimeout (Just 5)
57	$ defaultSettings
58	where
59	onSignal closeSocket =
60	forM_ [sigTERM, sigINT] $ \sig -> installHandler sig (CatchOnce closeSocket) Nothing
61
62	listenOn :: Bind -> IO Socket
63	listenOn = \case
64	UnixSocket path -> do
65	removeIfExists path
66	sock <- socket AF_UNIX Stream defaultProtocol
67	bind sock (SockAddrUnix path)
68	listen sock 1024
69	pure sock
70	Loopback addr port -> do
71	sock <- socket AF_INET Stream defaultProtocol
72	setSocketOption sock ReuseAddr 1
73	bind sock (SockAddrInet port (tupleToHostAddress addr))
74	listen sock 1024
75	pure sock
76
77	cleanUp :: Bind -> Socket -> IO ()
78	cleanUp target sock = do
79	close sock
80	case target of
81	UnixSocket path -> removeIfExists path
82	Loopback _ _ -> pure ()
83
84	removeIfExists :: FilePath -> IO ()
85	removeIfExists path = removeLink path `catch` \e -> unless (isDoesNotExistError e) (throwIO e)
86
87	parseArgs :: [String] -> Options -> Either String Options
88	parseArgs args o = case args of
89	[] -> Right o
90	"--socket" : path : rest -> parseArgs rest o {optBind = Just (UnixSocket path)}
91	"--listen" : addr : rest -> do
92	b <- parseListen addr
93	parseArgs rest o {optBind = Just b}
94	"--db" : path : rest -> parseArgs rest o {optDb = Just path}
95	flag : _ -> Left ("unexpected argument " <> show flag)
96
97	-- | Only 127.0.0.1: this app never listens anywhere else.
98	parseListen :: String -> Either String Bind
99	parseListen s = case break (== ':') s of
100	("127.0.0.1", ':' : portText)
101	| Just port <- readMaybe portText
102	, port > 0 && port < (65536 :: Int) ->
103	Right (Loopback (127, 0, 0, 1) (fromIntegral port))
104	_ -> Left ("--listen wants 127.0.0.1:<port>, not " <> show s)
105
106	showAddr :: (Word8, Word8, Word8, Word8) -> PortNumber -> String
107	showAddr (a, b, c, d) port = concat [show a, ".", show b, ".", show c, ".", show d, ":", show port]
108
109	describe :: Bind -> String
110	describe = \case
111	UnixSocket path -> path
112	Loopback addr port -> showAddr addr port
113
114	usage :: String -> IO a
115	usage err = do
116	hPutStrLn stderr ("todo-haskell: " <> err)
117	hPutStrLn stderr "usage: todo-haskell (--socket <path> | --listen 127.0.0.1:<port>) --db <path>"
118	exitWith (ExitFailure 2)
119