summaryrefslogtreecommitdiff
path: root/fig-utils
diff options
context:
space:
mode:
Diffstat (limited to 'fig-utils')
-rw-r--r--fig-utils/fig-utils.cabal36
-rw-r--r--fig-utils/src/Fig/Prelude.hs119
-rw-r--r--fig-utils/src/Fig/Utils.hs3
-rw-r--r--fig-utils/src/Fig/Utils/Net.hs81
-rw-r--r--fig-utils/src/Fig/Utils/SExpr.hs108
5 files changed, 347 insertions, 0 deletions
diff --git a/fig-utils/fig-utils.cabal b/fig-utils/fig-utils.cabal
new file mode 100644
index 0000000..9bb115d
--- /dev/null
+++ b/fig-utils/fig-utils.cabal
@@ -0,0 +1,36 @@
+cabal-version: 3.4
+name: fig-utils
+version: 0.1.0.0
+
+common defaults
+ ghc-options: -Wall
+ default-language: GHC2021
+ default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs
+
+library
+ import: defaults
+ hs-source-dirs: src
+ exposed-modules:
+ Fig.Prelude
+ Fig.Utils
+ Fig.Utils.Net
+ Fig.Utils.SExpr
+ build-depends:
+ base
+ , binary
+ , bytestring
+ , containers
+ , directory
+ , containers
+ , directory
+ , filepath
+ , megaparsec
+ , mtl
+ , network
+ , safe-exceptions
+ , template-haskell
+ , text
+ , time
+ , transformers
+ , unordered-containers
+ , vector
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"
+ }
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 08:09:13 +0000