{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Program.Mighty.Route (
  -- * Paring a routing file
    parseRoute
  -- * Types
  , RouteDB
  , Route(..)
  , Block(..)
  , Src
  , Dst
  , Domain
  , Port
  -- * RouteDBRef
  , 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

----------------------------------------------------------------

-- | A logical path specified in URL.
type Src      = Path
-- | A physical path in a file system.
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]

----------------------------------------------------------------

-- | Parsing a route file.
parseRoute :: FilePath
           -> Domain -- ^ A default domain, typically \"localhost\"
           -> Port   -- ^ A default port, typically 80.
           -> 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

-- [host1][:port2]/path2

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