Initial commit

4 files changed, 311 insertions, 0 deletions

diff --git a/fig-utils/src/Fig/Prelude.hs b/fig-utils/src/Fig/Prelude.hs
new file mode 100644
index 0000000..ceddba0
--- /dev/null
+++ b/fig-utils/src/Fig/Prelude.hs
@@ -0,0 +1,119 @@
+module Fig.Prelude
+  ( quot, mod, rem, quotRem
+  , module GHC.Num
+  , module GHC.Float
+
+  , module System.IO
+  , module System.FilePath.Posix
+
+  , module Data.Kind
+  , module Data.Void
+  , module Data.Bool
+  , module Data.Char
+  , module Data.Int
+  , module Data.Text
+  , module Data.Text.IO
+  , module Data.Text.Encoding
+  , module Data.ByteString
+  , module Data.Tuple
+  , module Data.Maybe
+  , module Data.Either
+  , module Data.List
+  , module Data.Function
+  , module Data.Eq
+  , module Data.Ord
+  , module Data.Semigroup
+  , module Data.Monoid
+  , module Data.Functor
+  , module Data.Bifunctor
+  , module Data.Traversable
+  , module Data.Foldable
+
+  , module Text.Show
+  , module Text.Read
+
+  , module Control.Applicative
+  , module Control.Monad
+  , module Control.Monad.IO.Class
+  , module Control.Monad.State.Class
+  , module Control.Monad.Reader.Class
+  , module Control.Exception.Safe
+
+  , tshow
+  , headMay, atMay
+  , throwLeft
+  , log
+
+  , Pretty(..)
+  ) where
+
+import Prelude (quot, mod, rem, quotRem)
+
+import GHC.Num (Num(..), Integer)
+import GHC.Float (Double)
+
+import System.IO (IO, stdin, stdout, stderr, FilePath, Handle)
+import System.FilePath.Posix ((</>))
+
+import Data.Kind (Type)
+import Data.Void (Void)
+import Data.Bool (Bool(..), otherwise, not, (&&), (||))
+import Data.Char (Char, isUpper)
+import Data.Int (Int)
+import Data.Text (Text, pack, unpack, unwords)
+import Data.Text.IO (putStrLn)
+import Data.Text.Encoding (decodeUtf8, decodeUtf8', encodeUtf8)
+import Data.ByteString (ByteString, readFile, writeFile)
+import Data.Tuple (fst, snd, curry, uncurry, swap)
+import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust, catMaybes)
+import Data.Either (Either(..))
+import Data.List (take, drop, dropWhile, filter, reverse, lookup, zip, zip3, replicate, sortOn, concatMap, elemIndex)
+import Data.Function (id, const, flip, ($), (&), (.))
+import Data.Eq (Eq(..))
+import Data.Ord (Ord(..), Down(..))
+import Data.Semigroup(Semigroup(..), (<>))
+import Data.Monoid (Monoid(..), mconcat)
+import Data.Functor (Functor(..), (<$>), (<$), ($>))
+import Data.Bifunctor (Bifunctor(..), first, second)
+import Data.Traversable (Traversable(..), forM, sequence)
+import Data.Foldable (Foldable(..), any, all, mapM_, forM_)
+import qualified Data.Time.Clock as Time
+import qualified Data.Time.Format as Time
+
+import Text.Show (Show(..))
+import Text.Read (readMaybe)
+
+import Control.Applicative (Applicative(..), (<*), (*>))
+import Control.Monad (Monad(..), join, forever, mapM, forM, foldM, void, (>>=), (=<<), (>=>), (<=<))
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.State.Class (MonadState(..), get, put, modify)
+import Control.Monad.Reader.Class (MonadReader(..), ask)
+import Control.Exception.Safe (Exception, SomeException, IOException, MonadThrow, MonadCatch, MonadMask, throwM, try, catch, catchIO, bracket, bracketOnError)
+
+tshow :: Show a => a -> Text
+tshow = pack . show
+
+headMay :: [a] -> Maybe a
+headMay [] = Nothing
+headMay (x:_) = Just x
+
+atMay :: [a] -> Int -> Maybe a
+atMay [] _ = Nothing
+atMay (x:_) 0 = Just x
+atMay (_:xs) n = atMay xs $ n - 1
+
+throwLeft :: (Exception e, MonadThrow m) => (b -> e) -> Either b a -> m a
+throwLeft f (Left x) = throwM $ f x
+throwLeft _ (Right x) = pure x
+
+log :: MonadIO m => Text -> m ()
+log msg = do
+  t <- liftIO Time.getCurrentTime
+  let time = Time.formatTime Time.defaultTimeLocale "[%F %T] " t
+  liftIO . putStrLn $ pack time <> msg
+
+class Pretty a where
+  pretty :: a -> Text
+
+instance Pretty Void where
+  pretty _ = ""
diff --git a/fig-utils/src/Fig/Utils.hs b/fig-utils/src/Fig/Utils.hs
new file mode 100644
index 0000000..5b328e2
--- /dev/null
+++ b/fig-utils/src/Fig/Utils.hs
@@ -0,0 +1,3 @@
+module Fig.Utils where
+
+import Fig.Prelude
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"
+  }