Initial commit

2 files changed, 189 insertions, 0 deletions

diff --git a/fig-utils/src/Fig/Utils/Net.hs b/fig-utils/src/Fig/Utils/Net.hs
new file mode 100644
index 0000000..d0b1890
--- /dev/null
+++ b/fig-utils/src/Fig/Utils/Net.hs
@@ -0,0 +1,81 @@
+module Fig.Utils.Net
+  ( server
+  , client
+  ) where
+
+import Fig.Prelude
+
+import System.IO (IOMode(..), BufferMode(..), hClose, hSetBuffering)
+
+import qualified Control.Concurrent as Conc
+
+import qualified Network.Socket as Sock
+
+newtype FigNetException = FigNetException Text
+  deriving (Show, Eq, Ord)
+instance Exception FigNetException
+
+resolveAddr :: forall m.
+  (MonadIO m, MonadThrow m) =>
+  (Maybe Text, Text) ->
+  Bool ->
+  m Sock.AddrInfo
+resolveAddr (host, port) serv = do
+  maddr <- liftIO $ headMay <$> Sock.getAddrInfo
+    (Just $ Sock.defaultHints
+     { Sock.addrFlags = [Sock.AI_PASSIVE | serv]
+     , Sock.addrSocketType = Sock.Stream
+     }
+    )
+    (unpack <$> host)
+    (Just $ unpack port)
+  maybe (throwM $ FigNetException "Failed to resolve address") pure maddr
+
+server :: forall m.
+  (MonadIO m, MonadThrow m, MonadMask m) =>
+  (Maybe Text, Text) ->
+  m (Handle -> Sock.SockAddr -> (IO (), IO ())) ->
+  m ()
+server loc onConn = do
+  addr <- resolveAddr loc True
+  bracket (liftIO $ Sock.openSocket addr) (liftIO . Sock.close) \sock -> do
+    liftIO $ Sock.setSocketOption sock Sock.ReuseAddr 1
+    liftIO $ Sock.withFdSocket sock Sock.setCloseOnExecIfNeeded
+    liftIO $ Sock.bind sock $ Sock.addrAddress addr
+    liftIO $ Sock.listen sock 4096
+    log $ "Listening on " <> tshow (Sock.addrAddress addr)
+    forever do
+      let toHandle = bracketOnError (liftIO $ Sock.accept sock) (liftIO . Sock.close . fst) \(conn, peer) ->
+            liftIO $ (,peer) <$> Sock.socketToHandle conn ReadWriteMode
+      bracketOnError toHandle (liftIO . hClose . fst) \(hdl, peer) -> do
+        liftIO $ log $ "Client " <> tshow peer <> " connected"
+        liftIO $ hSetBuffering hdl LineBuffering
+        (handler, cleanup) <- ($ peer) . ($ hdl) <$> onConn
+        liftIO $ Conc.forkFinally handler \res -> do
+          case res of
+            Right _ -> log $ "Client " <> tshow peer <> " disconnected"
+            Left err -> log $ "Client " <> tshow peer <> " disconnected: " <> tshow err
+          cleanup
+          hClose hdl
+
+client :: forall m.
+  (MonadIO m, MonadThrow m, MonadMask m) =>
+  (Text, Text) ->
+  m (Handle -> (m (), m ())) ->
+  m ()
+client loc onConn = do
+  addr <- resolveAddr (first Just loc) False
+  let openConnectHandle = do
+        bracketOnError (liftIO $ Sock.openSocket addr) (liftIO . Sock.close) \sock -> do
+          liftIO . Sock.connect sock $ Sock.addrAddress addr
+          hdl <- liftIO $ Sock.socketToHandle sock ReadWriteMode
+          (handler, cleanup) <- ($ hdl) <$> onConn
+          pure (hdl, handler, cleanup)
+  bracket openConnectHandle
+    ( \(hdl, _, cleanup) -> do
+        cleanup 
+        liftIO $ hClose hdl
+    )
+    ( \(_, handler, _) -> do
+        handler
+    )
diff --git a/fig-utils/src/Fig/Utils/SExpr.hs b/fig-utils/src/Fig/Utils/SExpr.hs
new file mode 100644
index 0000000..53a50a5
--- /dev/null
+++ b/fig-utils/src/Fig/Utils/SExpr.hs
@@ -0,0 +1,108 @@
+{-# Language TemplateHaskellQuotes #-}
+
+module Fig.Utils.SExpr
+  ( SExprWith(..)
+  , SExpr
+  , parseSExpr
+  , sexp
+  ) where
+
+import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Quote as Q
+import qualified Language.Haskell.TH.Syntax as Q
+
+import Fig.Prelude
+
+import Control.Monad (fail)
+
+import Data.Data (Data, cast)
+import Data.Char (isSpace)
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer
+
+data SExprWith :: Type -> Type where
+  SExprExt :: forall a. a -> SExprWith a
+  SExprSymbol :: forall a. Text -> SExprWith a
+  SExprString :: forall a. Text -> SExprWith a
+  SExprInteger :: forall a. Integer -> SExprWith a
+  SExprFloat :: forall a. Double -> SExprWith a
+  SExprList :: forall a. [SExprWith a] -> SExprWith a
+deriving instance Show a => Show (SExprWith a)
+deriving instance Eq a => Eq (SExprWith a)
+deriving instance Ord a => Ord (SExprWith a)
+deriving instance Data a => Data (SExprWith a)
+deriving instance Functor SExprWith
+
+instance Pretty a => Pretty (SExprWith a) where
+  pretty (SExprExt x) = pretty x
+  pretty (SExprSymbol s) = s
+  pretty (SExprString s) = tshow s
+  pretty (SExprInteger i) = tshow i
+  pretty (SExprFloat f) = tshow f
+  pretty (SExprList xs) = "(" <> unwords (pretty <$> xs) <> ")"
+
+type SExpr = SExprWith Void
+
+type Parser = Parsec Void Text
+
+sexprWith :: forall a. Parser a -> Parser (SExprWith a)
+sexprWith ext = spaces *>
+  ( SExprExt <$> ext
+    <|> SExprString . pack <$> (char '"' *> manyTill charLiteral (char '"'))
+    <|> SExprInteger <$> decimal
+    <|> SExprFloat <$> float
+    <|> SExprSymbol . pack <$> some symchar
+    <|> SExprList <$> (char '(' *> spaces *> many (spaces *> sexprWith ext <* spaces) <* char ')')
+  )
+  where
+    spaces = many spaceChar
+    symchar = satisfy $ \c -> not (isSpace c || c `elem` special)
+    special :: [Char]
+    special = "()"
+
+parseSExprWith :: Parser a -> Text -> Maybe (SExprWith a)
+parseSExprWith ext inp = case runParser (sexprWith ext) "" inp of
+  Left _ -> Nothing
+  Right s -> Just s
+
+parseSExpr :: Text -> Maybe SExpr
+parseSExpr = parseSExprWith empty
+
+data AntiSExpr
+  = AntiSExpr Text
+  | AntiSExprSplice Text
+  deriving (Show, Eq, Ord, Data)
+
+antisexpr :: Parser AntiSExpr
+antisexpr =
+  AntiSExprSplice . pack <$> (string ",@" *> ((:) <$> letterChar <*> many alphaNumChar))
+  <|> AntiSExpr . pack <$> (char ',' *> ((:) <$> letterChar <*> many alphaNumChar))
+
+antiSExprExp :: SExprWith AntiSExpr -> Maybe (Q.Q Q.Exp)
+antiSExprExp (SExprExt (AntiSExpr nm)) = Just $ TH.varE (TH.mkName $ unpack nm)
+antiSExprExp (SExprList xs) = do
+  let exps = flip fmap xs \case
+        SExprExt (AntiSExprSplice nm) -> TH.varE . TH.mkName $ unpack nm
+        s -> TH.listE [liftSExpr s]
+  Just $ TH.appE
+    (TH.conE $ TH.mkName "SExprList")
+    (TH.appE (TH.varE $ TH.mkName "mconcat") (TH.listE exps) )
+antiSExprExp _ = Nothing
+
+liftText :: Text -> Q.Q Q.Exp
+liftText txt = Q.AppE (Q.VarE 'pack) <$> Q.lift (unpack txt)
+
+liftSExpr :: Data a => a -> Q.Q Q.Exp
+liftSExpr = Q.dataToExpQ (\a -> maybe (liftText <$> cast a) antiSExprExp $ cast a)
+
+sexp :: Q.QuasiQuoter
+sexp = Q.QuasiQuoter
+  { quoteExp = \s -> do
+      expr <- maybe (fail "parse error") pure . parseSExprWith antisexpr $ pack s
+      liftSExpr expr
+  , quotePat = \_ -> fail "unsupported s-expression in pattern context"
+  , quoteType = \_ -> fail "unsupported s-expression in type context"
+  , quoteDec = \_ -> fail "unsupported s-expression in declaration context"
+  }