{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Program.Mighty.Route (
parseRoute
, RouteDB
, Route(..)
, Block(..)
, Src
, Dst
, Domain
, Port
, RouteDBRef
, newRouteDBRef
, readRouteDBRef
, writeRouteDBRef
) where
import Control.Monad
import Data.ByteString
import qualified Data.ByteString.Char8 as BS
import Data.IORef
#ifdef DHALL
import GHC.Natural (Natural)
#endif
import Network.Wai.Application.Classic
import Text.Parsec
import Text.Parsec.ByteString.Lazy
import Program.Mighty.Parser
type Src = Path
type Dst = Path
type Domain = ByteString
#ifdef DHALL
type Port = Natural
#else
type Port = Int
#endif
data Block = Block [Domain] [Route] deriving (Block -> Block -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c== :: Block -> Block -> Bool
Eq,Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show)
data Route = RouteFile Src Dst
| RouteRedirect Src Dst
| RouteCGI Src Dst
| RouteRevProxy Src Dst Domain Port
deriving (Route -> Route -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Route -> Route -> Bool
$c/= :: Route -> Route -> Bool
== :: Route -> Route -> Bool
$c== :: Route -> Route -> Bool
Eq,Int -> Route -> ShowS
[Route] -> ShowS
Route -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Route] -> ShowS
$cshowList :: [Route] -> ShowS
show :: Route -> String
$cshow :: Route -> String
showsPrec :: Int -> Route -> ShowS
$cshowsPrec :: Int -> Route -> ShowS
Show)
type RouteDB = [Block]
parseRoute :: FilePath
-> Domain
-> Port
-> IO RouteDB
parseRoute :: String -> Domain -> Int -> IO [Block]
parseRoute String
file Domain
ddom Int
dport = forall a. Parser a -> String -> IO a
parseFile (Domain -> Int -> Parser [Block]
routeDB Domain
ddom Int
dport) String
file
routeDB :: Domain -> Port -> Parser RouteDB
routeDB :: Domain -> Int -> Parser [Block]
routeDB Domain
ddom Int
dport = Parser ()
commentLines forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (Domain -> Int -> Parser Block
block Domain
ddom Int
dport) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
block :: Domain -> Port -> Parser Block
block :: Domain -> Int -> Parser Block
block Domain
ddom Int
dport = [Domain] -> [Route] -> Block
Block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity [Domain]
cdomains forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT ByteString () Identity Route
croute
where
cdomains :: ParsecT ByteString () Identity [Domain]
cdomains = ParsecT ByteString () Identity [Domain]
domains forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
commentLines
croute :: ParsecT ByteString () Identity Route
croute = Domain -> Int -> ParsecT ByteString () Identity Route
route Domain
ddom Int
dport forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
commentLines
domains :: Parser [Domain]
domains :: ParsecT ByteString () Identity [Domain]
domains = Parser ()
open forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT ByteString () Identity [Domain]
doms forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
close forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
trailing
where
open :: Parser ()
open = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
spcs
close :: Parser ()
close = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
spcs
doms :: ParsecT ByteString () Identity [Domain]
doms = (forall {u}. ParsecT ByteString u Identity Domain
domain forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy1` Parser ()
sep) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spcs
domain :: ParsecT ByteString u Identity Domain
domain = String -> Domain
BS.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"[], \t\n")
sep :: Parser ()
sep = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ()
spcs1
data Op = OpFile | OpCGI | OpRevProxy | OpRedirect
route :: Domain -> Port -> Parser Route
route :: Domain -> Int -> ParsecT ByteString () Identity Route
route Domain
ddom Int
dport = do
Domain
s <- Parser Domain
src
Op
o <- ParsecT ByteString () Identity Op
op
case Op
o of
Op
OpFile -> Domain -> Domain -> Route
RouteFile Domain
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Domain
dst forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
trailing
Op
OpRedirect -> Domain -> Domain -> Route
RouteRedirect Domain
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Domain
dst' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
trailing
Op
OpCGI -> Domain -> Domain -> Route
RouteCGI Domain
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Domain
dst forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
trailing
Op
OpRevProxy -> do
(Domain
dom,Int
prt,Domain
d) <- Domain -> Int -> Parser (Domain, Int, Domain)
domPortDst Domain
ddom Int
dport
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Domain -> Domain -> Domain -> Int -> Route
RouteRevProxy Domain
s Domain
d Domain
dom Int
prt
where
src :: Parser Domain
src = Parser Domain
path
dst :: Parser Domain
dst = Parser Domain
path
dst' :: Parser Domain
dst' = Parser Domain
path'
op0 :: ParsecT ByteString u Identity Op
op0 = Op
OpFile forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"->"
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Op
OpRedirect forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"<<"
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Op
OpCGI forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"=>"
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Op
OpRevProxy forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
">>"
op :: ParsecT ByteString () Identity Op
op = forall {u}. ParsecT ByteString u Identity Op
op0 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spcs
path :: Parser Path
path :: Parser Domain
path = do
Char
c <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'/'
String -> Domain
BS.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"[], \t\n") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spcs
path' :: Parser Path
path' :: Parser Domain
path' = String -> Domain
BS.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"[], \t\n") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spcs
domPortDst :: Domain -> Port -> Parser (Domain, Port, Dst)
domPortDst :: Domain -> Int -> Parser (Domain, Int, Domain)
domPortDst Domain
ddom Int
dport = (Domain
ddom,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {u}. ParsecT ByteString u Identity Int
port forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Domain
path
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try((,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {u}. ParsecT ByteString u Identity Domain
domain forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {u}. ParsecT ByteString u Identity Int
port forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Domain
path)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (,Int
dport,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {u}. ParsecT ByteString u Identity Domain
domain forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Domain
path
where
domain :: ParsecT ByteString u Identity Domain
domain = String -> Domain
BS.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
":/[], \t\n")
port :: ParsecT ByteString u Identity Int
port = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf [Char
'0'..Char
'9'])
newtype RouteDBRef = RouteDBRef (IORef RouteDB)
newRouteDBRef :: RouteDB -> IO RouteDBRef
newRouteDBRef :: [Block] -> IO RouteDBRef
newRouteDBRef [Block]
rout = IORef [Block] -> RouteDBRef
RouteDBRef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef [Block]
rout
readRouteDBRef :: RouteDBRef -> IO RouteDB
readRouteDBRef :: RouteDBRef -> IO [Block]
readRouteDBRef (RouteDBRef IORef [Block]
ref) = forall a. IORef a -> IO a
readIORef IORef [Block]
ref
writeRouteDBRef :: RouteDBRef -> RouteDB -> IO ()
writeRouteDBRef :: RouteDBRef -> [Block] -> IO ()
writeRouteDBRef (RouteDBRef IORef [Block]
ref) [Block]
rout = forall a. IORef a -> a -> IO ()
writeIORef IORef [Block]
ref [Block]
rout