{-# 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
(Block -> Block -> Bool) -> (Block -> Block -> Bool) -> Eq Block
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
(Int -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
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
(Route -> Route -> Bool) -> (Route -> Route -> Bool) -> Eq Route
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
(Int -> Route -> ShowS)
-> (Route -> String) -> ([Route] -> ShowS) -> Show Route
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 = Parser [Block] -> String -> IO [Block]
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 Parser () -> Parser [Block] -> Parser [Block]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT ByteString () Identity Block -> Parser [Block]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (Domain -> Int -> ParsecT ByteString () Identity Block
block Domain
ddom Int
dport) Parser [Block] -> Parser () -> Parser [Block]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

block :: Domain -> Port -> Parser Block
block :: Domain -> Int -> ParsecT ByteString () Identity Block
block Domain
ddom Int
dport = [Domain] -> [Route] -> Block
Block ([Domain] -> [Route] -> Block)
-> ParsecT ByteString () Identity [Domain]
-> ParsecT ByteString () Identity ([Route] -> Block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity [Domain]
cdomains ParsecT ByteString () Identity ([Route] -> Block)
-> ParsecT ByteString () Identity [Route]
-> ParsecT ByteString () Identity Block
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT ByteString () Identity Route
-> ParsecT ByteString () Identity [Route]
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 ParsecT ByteString () Identity [Domain]
-> Parser () -> ParsecT ByteString () Identity [Domain]
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  ParsecT ByteString () Identity Route
-> Parser () -> ParsecT ByteString () Identity Route
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 Parser ()
-> ParsecT ByteString () Identity [Domain]
-> ParsecT ByteString () Identity [Domain]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT ByteString () Identity [Domain]
doms ParsecT ByteString () Identity [Domain]
-> Parser () -> ParsecT ByteString () Identity [Domain]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
close ParsecT ByteString () Identity [Domain]
-> Parser () -> ParsecT ByteString () Identity [Domain]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
trailing
  where
    open :: Parser ()
open  = () () -> ParsecT ByteString () Identity Char -> Parser ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[' Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
spcs
    close :: Parser ()
close = () () -> ParsecT ByteString () Identity Char -> Parser ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']' Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
spcs
    doms :: ParsecT ByteString () Identity [Domain]
doms = (ParsecT ByteString () Identity Domain
forall u. ParsecT ByteString u Identity Domain
domain ParsecT ByteString () Identity Domain
-> Parser () -> ParsecT ByteString () Identity [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) ParsecT ByteString () Identity [Domain]
-> Parser () -> ParsecT ByteString () Identity [Domain]
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 (String -> Domain)
-> ParsecT ByteString u Identity String
-> ParsecT ByteString u Identity Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT ByteString u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"[], \t\n")
    sep :: Parser ()
sep = () () -> Parser () -> Parser ()
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 <- ParsecT ByteString () Identity Domain
src
    Op
o <- ParsecT ByteString () Identity Op
op
    case Op
o of
        Op
OpFile     -> Domain -> Domain -> Route
RouteFile     Domain
s (Domain -> Route)
-> ParsecT ByteString () Identity Domain
-> ParsecT ByteString () Identity Route
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Domain
dst ParsecT ByteString () Identity Route
-> Parser () -> ParsecT ByteString () Identity Route
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
trailing
        Op
OpRedirect -> Domain -> Domain -> Route
RouteRedirect Domain
s (Domain -> Route)
-> ParsecT ByteString () Identity Domain
-> ParsecT ByteString () Identity Route
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Domain
dst' ParsecT ByteString () Identity Route
-> Parser () -> ParsecT ByteString () Identity Route
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
trailing
        Op
OpCGI      -> Domain -> Domain -> Route
RouteCGI      Domain
s (Domain -> Route)
-> ParsecT ByteString () Identity Domain
-> ParsecT ByteString () Identity Route
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Domain
dst ParsecT ByteString () Identity Route
-> Parser () -> ParsecT ByteString () Identity Route
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
            Route -> ParsecT ByteString () Identity Route
forall (m :: * -> *) a. Monad m => a -> m a
return (Route -> ParsecT ByteString () Identity Route)
-> Route -> ParsecT ByteString () Identity Route
forall a b. (a -> b) -> a -> b
$ Domain -> Domain -> Domain -> Int -> Route
RouteRevProxy Domain
s Domain
d Domain
dom Int
prt
  where
    src :: ParsecT ByteString () Identity Domain
src = ParsecT ByteString () Identity Domain
path
    dst :: ParsecT ByteString () Identity Domain
dst = ParsecT ByteString () Identity Domain
path
    dst' :: ParsecT ByteString () Identity Domain
dst' = ParsecT ByteString () Identity Domain
path'
    op0 :: ParsecT ByteString u Identity Op
op0 = Op
OpFile     Op
-> ParsecT ByteString u Identity String
-> ParsecT ByteString u Identity Op
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT ByteString u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"->"
      ParsecT ByteString u Identity Op
-> ParsecT ByteString u Identity Op
-> ParsecT ByteString u Identity Op
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Op
OpRedirect Op
-> ParsecT ByteString u Identity String
-> ParsecT ByteString u Identity Op
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT ByteString u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"<<"
      ParsecT ByteString u Identity Op
-> ParsecT ByteString u Identity Op
-> ParsecT ByteString u Identity Op
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Op
OpCGI      Op
-> ParsecT ByteString u Identity String
-> ParsecT ByteString u Identity Op
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT ByteString u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"=>"
      ParsecT ByteString u Identity Op
-> ParsecT ByteString u Identity Op
-> ParsecT ByteString u Identity Op
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Op
OpRevProxy Op
-> ParsecT ByteString u Identity String
-> ParsecT ByteString u Identity Op
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT ByteString u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
">>"
    op :: ParsecT ByteString () Identity Op
op  = ParsecT ByteString () Identity Op
forall u. ParsecT ByteString u Identity Op
op0 ParsecT ByteString () Identity Op
-> Parser () -> ParsecT ByteString () Identity Op
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spcs

path :: Parser Path
path :: ParsecT ByteString () Identity Domain
path = do
    Char
c <- Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'/'
    String -> Domain
BS.pack (String -> Domain) -> ShowS -> String -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:) (String -> Domain)
-> ParsecT ByteString () Identity String
-> ParsecT ByteString () Identity Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"[], \t\n") ParsecT ByteString () Identity Domain
-> Parser () -> ParsecT ByteString () Identity Domain
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spcs

path' :: Parser Path
path' :: ParsecT ByteString () Identity Domain
path' = String -> Domain
BS.pack (String -> Domain)
-> ParsecT ByteString () Identity String
-> ParsecT ByteString () Identity Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"[], \t\n") ParsecT ByteString () Identity Domain
-> Parser () -> ParsecT ByteString () Identity Domain
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,,) (Int -> Domain -> (Domain, Int, Domain))
-> ParsecT ByteString () Identity Int
-> ParsecT ByteString () Identity (Domain -> (Domain, Int, Domain))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Int
forall u. ParsecT ByteString u Identity Int
port ParsecT ByteString () Identity (Domain -> (Domain, Int, Domain))
-> ParsecT ByteString () Identity Domain
-> Parser (Domain, Int, Domain)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT ByteString () Identity Domain
path
                    Parser (Domain, Int, Domain)
-> Parser (Domain, Int, Domain) -> Parser (Domain, Int, Domain)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser (Domain, Int, Domain) -> Parser (Domain, Int, Domain)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try((,,) (Domain -> Int -> Domain -> (Domain, Int, Domain))
-> ParsecT ByteString () Identity Domain
-> ParsecT
     ByteString () Identity (Int -> Domain -> (Domain, Int, Domain))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Domain
forall u. ParsecT ByteString u Identity Domain
domain ParsecT
  ByteString () Identity (Int -> Domain -> (Domain, Int, Domain))
-> ParsecT ByteString () Identity Int
-> ParsecT ByteString () Identity (Domain -> (Domain, Int, Domain))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT ByteString () Identity Int
forall u. ParsecT ByteString u Identity Int
port ParsecT ByteString () Identity (Domain -> (Domain, Int, Domain))
-> ParsecT ByteString () Identity Domain
-> Parser (Domain, Int, Domain)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT ByteString () Identity Domain
path)
                    Parser (Domain, Int, Domain)
-> Parser (Domain, Int, Domain) -> Parser (Domain, Int, Domain)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (,Int
dport,) (Domain -> Domain -> (Domain, Int, Domain))
-> ParsecT ByteString () Identity Domain
-> ParsecT ByteString () Identity (Domain -> (Domain, Int, Domain))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () Identity Domain
forall u. ParsecT ByteString u Identity Domain
domain ParsecT ByteString () Identity (Domain -> (Domain, Int, Domain))
-> ParsecT ByteString () Identity Domain
-> Parser (Domain, Int, Domain)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT ByteString () Identity Domain
path
  where
    domain :: ParsecT ByteString u Identity Domain
domain = String -> Domain
BS.pack (String -> Domain)
-> ParsecT ByteString u Identity String
-> ParsecT ByteString u Identity Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT ByteString u Identity Char
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
        ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT ByteString u Identity Char
 -> ParsecT ByteString u Identity ())
-> ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT ByteString u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
        String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT ByteString u Identity String
-> ParsecT ByteString u Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString u Identity Char
-> ParsecT ByteString u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT ByteString u Identity Char
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 (IORef [Block] -> RouteDBRef)
-> IO (IORef [Block]) -> IO RouteDBRef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block] -> IO (IORef [Block])
forall a. a -> IO (IORef a)
newIORef [Block]
rout

readRouteDBRef :: RouteDBRef -> IO RouteDB
readRouteDBRef :: RouteDBRef -> IO [Block]
readRouteDBRef (RouteDBRef IORef [Block]
ref) = IORef [Block] -> IO [Block]
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 = IORef [Block] -> [Block] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Block]
ref [Block]
rout