module Program.Mighty.Route (
parseRoute
, RouteDB
, Route(..)
, Block(..)
, Src
, Dst
, Domain
, Port
, RouteDBRef
, newRouteDBRef
, readRouteDBRef
, writeRouteDBRef
) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative hiding (many,(<|>))
#endif
import Control.Monad
import Data.ByteString
import qualified Data.ByteString.Char8 as BS
import Data.IORef
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
type Port = Int
data Block = Block [Domain] [Route] deriving (Eq,Show)
data Route = RouteFile Src Dst
| RouteRedirect Src Dst
| RouteCGI Src Dst
| RouteRevProxy Src Dst Domain Port
deriving (Eq,Show)
type RouteDB = [Block]
parseRoute :: FilePath
-> Domain
-> Port
-> IO RouteDB
parseRoute file ddom dport = parseFile (routeDB ddom dport) file
routeDB :: Domain -> Port -> Parser RouteDB
routeDB ddom dport = commentLines *> many1 (block ddom dport) <* eof
block :: Domain -> Port -> Parser Block
block ddom dport = Block <$> cdomains <*> many croute
where
cdomains = domains <* commentLines
croute = route ddom dport <* commentLines
domains :: Parser [Domain]
domains = open *> doms <* close <* trailing
where
open = () <$ char '[' *> spcs
close = () <$ char ']' *> spcs
doms = (domain `sepBy1` sep) <* spcs
domain = BS.pack <$> many1 (noneOf "[], \t\n")
sep = () <$ spcs1
data Op = OpFile | OpCGI | OpRevProxy | OpRedirect
route :: Domain -> Port -> Parser Route
route ddom dport = do
s <- src
o <- op
case o of
OpFile -> RouteFile s <$> dst <* trailing
OpRedirect -> RouteRedirect s <$> dst' <* trailing
OpCGI -> RouteCGI s <$> dst <* trailing
OpRevProxy -> do
(dom,prt,d) <- domPortDst ddom dport
return $ RouteRevProxy s d dom prt
where
src = path
dst = path
dst' = path'
op0 = OpFile <$ string "->"
<|> OpRedirect <$ string "<<"
<|> OpCGI <$ string "=>"
<|> OpRevProxy <$ string ">>"
op = op0 <* spcs
path :: Parser Path
path = do
c <- char '/'
BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs
path' :: Parser Path
path' = BS.pack <$> many (noneOf "[], \t\n") <* spcs
domPortDst :: Domain -> Port -> Parser (Domain, Port, Dst)
domPortDst ddom dport = (ddom,,) <$> port <*> path
<|> try((,,) <$> domain <*> port <*> path)
<|> (,dport,) <$> domain <*> path
where
domain = BS.pack <$> many1 (noneOf ":/[], \t\n")
port = do
void $ char ':'
read <$> many1 (oneOf ['0'..'9'])
newtype RouteDBRef = RouteDBRef (IORef RouteDB)
newRouteDBRef :: RouteDB -> IO RouteDBRef
newRouteDBRef rout = RouteDBRef <$> newIORef rout
readRouteDBRef :: RouteDBRef -> IO RouteDB
readRouteDBRef (RouteDBRef ref) = readIORef ref
writeRouteDBRef :: RouteDBRef -> RouteDB -> IO ()
writeRouteDBRef (RouteDBRef ref) rout = writeIORef ref rout